1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2021 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
24 #include "tm.h" /* For BITS_PER_UNIT. */
27 #include "intrinsic.h"
29 #include "target-memory.h"
30 #include "constructor.h"
31 #include "version.h" /* For version_string. */
35 static int min_max_choose (gfc_expr
*, gfc_expr
*, int, bool back_val
= false);
37 gfc_expr gfc_bad_expr
;
39 static gfc_expr
*simplify_size (gfc_expr
*, gfc_expr
*, int);
42 /* Note that 'simplification' is not just transforming expressions.
43 For functions that are not simplified at compile time, range
44 checking is done if possible.
46 The return convention is that each simplification function returns:
48 A new expression node corresponding to the simplified arguments.
49 The original arguments are destroyed by the caller, and must not
50 be a part of the new expression.
52 NULL pointer indicating that no simplification was possible and
53 the original expression should remain intact.
55 An expression pointer to gfc_bad_expr (a static placeholder)
56 indicating that some error has prevented simplification. The
57 error is generated within the function and should be propagated
60 By the time a simplification function gets control, it has been
61 decided that the function call is really supposed to be the
62 intrinsic. No type checking is strictly necessary, since only
63 valid types will be passed on. On the other hand, a simplification
64 subroutine may have to look at the type of an argument as part of
67 Array arguments are only passed to these subroutines that implement
68 the simplification of transformational intrinsics.
70 The functions in this file don't have much comment with them, but
71 everything is reasonably straight-forward. The Standard, chapter 13
72 is the best comment you'll find for this file anyway. */
74 /* Range checks an expression node. If all goes well, returns the
75 node, otherwise returns &gfc_bad_expr and frees the node. */
78 range_check (gfc_expr
*result
, const char *name
)
83 if (result
->expr_type
!= EXPR_CONSTANT
)
86 switch (gfc_range_check (result
))
92 gfc_error ("Result of %s overflows its kind at %L", name
,
97 gfc_error ("Result of %s underflows its kind at %L", name
,
102 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
106 gfc_error ("Result of %s gives range error for its kind at %L", name
,
111 gfc_free_expr (result
);
112 return &gfc_bad_expr
;
116 /* A helper function that gets an optional and possibly missing
117 kind parameter. Returns the kind, -1 if something went wrong. */
120 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
127 if (k
->expr_type
!= EXPR_CONSTANT
)
129 gfc_error ("KIND parameter of %s at %L must be an initialization "
130 "expression", name
, &k
->where
);
134 if (gfc_extract_int (k
, &kind
)
135 || gfc_validate_kind (type
, kind
, true) < 0)
137 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
145 /* Converts an mpz_t signed variable into an unsigned one, assuming
146 two's complement representations and a binary width of bitsize.
147 The conversion is a no-op unless x is negative; otherwise, it can
148 be accomplished by masking out the high bits. */
151 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
157 /* Confirm that no bits above the signed range are unset if we
158 are doing range checking. */
159 if (flag_range_check
!= 0)
160 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
162 mpz_init_set_ui (mask
, 1);
163 mpz_mul_2exp (mask
, mask
, bitsize
);
164 mpz_sub_ui (mask
, mask
, 1);
166 mpz_and (x
, x
, mask
);
172 /* Confirm that no bits above the signed range are set if we
173 are doing range checking. */
174 if (flag_range_check
!= 0)
175 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
180 /* Converts an mpz_t unsigned variable into a signed one, assuming
181 two's complement representations and a binary width of bitsize.
182 If the bitsize-1 bit is set, this is taken as a sign bit and
183 the number is converted to the corresponding negative number. */
186 gfc_convert_mpz_to_signed (mpz_t x
, int bitsize
)
190 /* Confirm that no bits above the unsigned range are set if we are
191 doing range checking. */
192 if (flag_range_check
!= 0)
193 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
195 if (mpz_tstbit (x
, bitsize
- 1) == 1)
197 mpz_init_set_ui (mask
, 1);
198 mpz_mul_2exp (mask
, mask
, bitsize
);
199 mpz_sub_ui (mask
, mask
, 1);
201 /* We negate the number by hand, zeroing the high bits, that is
202 make it the corresponding positive number, and then have it
203 negated by GMP, giving the correct representation of the
206 mpz_add_ui (x
, x
, 1);
207 mpz_and (x
, x
, mask
);
216 /* Test that the expression is a constant array, simplifying if
217 we are dealing with a parameter array. */
220 is_constant_array_expr (gfc_expr
*e
)
223 bool array_OK
= true;
229 if (e
->expr_type
== EXPR_VARIABLE
&& e
->rank
> 0
230 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
231 gfc_simplify_expr (e
, 1);
233 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
236 for (c
= gfc_constructor_first (e
->value
.constructor
);
237 c
; c
= gfc_constructor_next (c
))
238 if (c
->expr
->expr_type
!= EXPR_CONSTANT
239 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
245 /* Check and expand the constructor. */
246 if (!array_OK
&& gfc_init_expr_flag
&& e
->rank
== 1)
248 array_OK
= gfc_reduce_init_expr (e
);
249 /* gfc_reduce_init_expr resets the flag. */
250 gfc_init_expr_flag
= true;
255 /* Recheck to make sure that any EXPR_ARRAYs have gone. */
256 for (c
= gfc_constructor_first (e
->value
.constructor
);
257 c
; c
= gfc_constructor_next (c
))
258 if (c
->expr
->expr_type
!= EXPR_CONSTANT
259 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
262 /* Make sure that the array has a valid shape. */
263 if (e
->shape
== NULL
&& e
->rank
== 1)
265 if (!gfc_array_size(e
, &size
))
267 e
->shape
= gfc_get_shape (1);
268 mpz_init_set (e
->shape
[0], size
);
275 /* Test for a size zero array. */
277 gfc_is_size_zero_array (gfc_expr
*array
)
280 if (array
->rank
== 0)
283 if (array
->expr_type
== EXPR_VARIABLE
&& array
->rank
> 0
284 && array
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
285 && array
->shape
!= NULL
)
287 for (int i
= 0; i
< array
->rank
; i
++)
288 if (mpz_cmp_si (array
->shape
[i
], 0) <= 0)
294 if (array
->expr_type
== EXPR_ARRAY
)
295 return array
->value
.constructor
== NULL
;
301 /* Initialize a transformational result expression with a given value. */
304 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
306 if (e
&& e
->expr_type
== EXPR_ARRAY
)
308 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
311 init_result_expr (ctor
->expr
, init
, array
);
312 ctor
= gfc_constructor_next (ctor
);
315 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
317 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
318 HOST_WIDE_INT length
;
324 e
->value
.logical
= (init
? 1 : 0);
329 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
330 else if (init
== INT_MAX
)
331 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
333 mpz_set_si (e
->value
.integer
, init
);
339 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
340 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
342 else if (init
== INT_MAX
)
343 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
345 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
349 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
355 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
356 gfc_extract_hwi (len
, &length
);
357 string
= gfc_get_wide_string (length
+ 1);
358 gfc_wide_memset (string
, 0, length
);
360 else if (init
== INT_MAX
)
362 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
363 gfc_extract_hwi (len
, &length
);
364 string
= gfc_get_wide_string (length
+ 1);
365 gfc_wide_memset (string
, 255, length
);
370 string
= gfc_get_wide_string (1);
373 string
[length
] = '\0';
374 e
->value
.character
.length
= length
;
375 e
->value
.character
.string
= string
;
387 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
388 if conj_a is true, the matrix_a is complex conjugated. */
391 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
392 gfc_expr
*matrix_b
, int stride_b
, int offset_b
,
395 gfc_expr
*result
, *a
, *b
, *c
;
397 /* Set result to an INTEGER(1) 0 for numeric types and .false. for
398 LOGICAL. Mixed-mode math in the loop will promote result to the
399 correct type and kind. */
400 if (matrix_a
->ts
.type
== BT_LOGICAL
)
401 result
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, false);
403 result
= gfc_get_int_expr (1, NULL
, 0);
404 result
->where
= matrix_a
->where
;
406 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
407 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
410 /* Copying of expressions is required as operands are free'd
411 by the gfc_arith routines. */
412 switch (result
->ts
.type
)
415 result
= gfc_or (result
,
416 gfc_and (gfc_copy_expr (a
),
423 if (conj_a
&& a
->ts
.type
== BT_COMPLEX
)
424 c
= gfc_simplify_conjg (a
);
426 c
= gfc_copy_expr (a
);
427 result
= gfc_add (result
, gfc_multiply (c
, gfc_copy_expr (b
)));
434 offset_a
+= stride_a
;
435 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
437 offset_b
+= stride_b
;
438 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
445 /* Build a result expression for transformational intrinsics,
449 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
450 int kind
, locus
* where
)
455 if (!dim
|| array
->rank
== 1)
456 return gfc_get_constant_expr (type
, kind
, where
);
458 result
= gfc_get_array_expr (type
, kind
, where
);
459 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
460 result
->rank
= array
->rank
- 1;
462 /* gfc_array_size() would count the number of elements in the constructor,
463 we have not built those yet. */
465 for (i
= 0; i
< result
->rank
; ++i
)
466 nelem
*= mpz_get_ui (result
->shape
[i
]);
468 for (i
= 0; i
< nelem
; ++i
)
470 gfc_constructor_append_expr (&result
->value
.constructor
,
471 gfc_get_constant_expr (type
, kind
, where
),
479 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
481 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
482 of COUNT intrinsic is .TRUE..
484 Interface and implementation mimics arith functions as
485 gfc_add, gfc_multiply, etc. */
488 gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
492 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
493 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
494 gcc_assert (op2
->value
.logical
);
496 result
= gfc_copy_expr (op1
);
497 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
505 /* Transforms an ARRAY with operation OP, according to MASK, to a
506 scalar RESULT. E.g. called if
508 REAL, PARAMETER :: array(n, m) = ...
509 REAL, PARAMETER :: s = SUM(array)
511 where OP == gfc_add(). */
514 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
515 transformational_op op
)
518 gfc_constructor
*array_ctor
, *mask_ctor
;
520 /* Shortcut for constant .FALSE. MASK. */
522 && mask
->expr_type
== EXPR_CONSTANT
523 && !mask
->value
.logical
)
526 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
528 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
529 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
533 a
= array_ctor
->expr
;
534 array_ctor
= gfc_constructor_next (array_ctor
);
536 /* A constant MASK equals .TRUE. here and can be ignored. */
540 mask_ctor
= gfc_constructor_next (mask_ctor
);
541 if (!m
->value
.logical
)
545 result
= op (result
, gfc_copy_expr (a
));
553 /* Transforms an ARRAY with operation OP, according to MASK, to an
554 array RESULT. E.g. called if
556 REAL, PARAMETER :: array(n, m) = ...
557 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
559 where OP == gfc_multiply().
560 The result might be post processed using post_op. */
563 simplify_transformation_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*dim
,
564 gfc_expr
*mask
, transformational_op op
,
565 transformational_op post_op
)
568 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
569 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
570 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
572 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
573 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
574 tmpstride
[GFC_MAX_DIMENSIONS
];
576 /* Shortcut for constant .FALSE. MASK. */
578 && mask
->expr_type
== EXPR_CONSTANT
579 && !mask
->value
.logical
)
582 /* Build an indexed table for array element expressions to minimize
583 linked-list traversal. Masked elements are set to NULL. */
584 gfc_array_size (array
, &size
);
585 arraysize
= mpz_get_ui (size
);
588 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
590 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
592 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
593 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
595 for (i
= 0; i
< arraysize
; ++i
)
597 arrayvec
[i
] = array_ctor
->expr
;
598 array_ctor
= gfc_constructor_next (array_ctor
);
602 if (!mask_ctor
->expr
->value
.logical
)
605 mask_ctor
= gfc_constructor_next (mask_ctor
);
609 /* Same for the result expression. */
610 gfc_array_size (result
, &size
);
611 resultsize
= mpz_get_ui (size
);
614 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
615 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
616 for (i
= 0; i
< resultsize
; ++i
)
618 resultvec
[i
] = result_ctor
->expr
;
619 result_ctor
= gfc_constructor_next (result_ctor
);
622 gfc_extract_int (dim
, &dim_index
);
623 dim_index
-= 1; /* zero-base index */
627 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
630 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
633 dim_extent
= mpz_get_si (array
->shape
[i
]);
634 dim_stride
= tmpstride
[i
];
638 extent
[n
] = mpz_get_si (array
->shape
[i
]);
639 sstride
[n
] = tmpstride
[i
];
640 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
644 done
= resultsize
<= 0;
649 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
651 *dest
= op (*dest
, gfc_copy_expr (*src
));
654 *dest
= post_op (*dest
, *dest
);
661 while (!done
&& count
[n
] == extent
[n
])
664 base
-= sstride
[n
] * extent
[n
];
665 dest
-= dstride
[n
] * extent
[n
];
668 if (n
< result
->rank
)
670 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
671 times, we'd warn for the last iteration, because the
672 array index will have already been incremented to the
673 array sizes, and we can't tell that this must make
674 the test against result->rank false, because ranks
675 must not exceed GFC_MAX_DIMENSIONS. */
676 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
687 /* Place updated expression in result constructor. */
688 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
689 for (i
= 0; i
< resultsize
; ++i
)
691 result_ctor
->expr
= resultvec
[i
];
692 result_ctor
= gfc_constructor_next (result_ctor
);
702 simplify_transformation (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
703 int init_val
, transformational_op op
)
708 size_zero
= gfc_is_size_zero_array (array
);
710 if (!(is_constant_array_expr (array
) || size_zero
)
711 || !gfc_is_constant_expr (dim
))
715 && !is_constant_array_expr (mask
)
716 && mask
->expr_type
!= EXPR_CONSTANT
)
719 result
= transformational_result (array
, dim
, array
->ts
.type
,
720 array
->ts
.kind
, &array
->where
);
721 init_result_expr (result
, init_val
, array
);
726 return !dim
|| array
->rank
== 1 ?
727 simplify_transformation_to_scalar (result
, array
, mask
, op
) :
728 simplify_transformation_to_array (result
, array
, dim
, mask
, op
, NULL
);
732 /********************** Simplification functions *****************************/
735 gfc_simplify_abs (gfc_expr
*e
)
739 if (e
->expr_type
!= EXPR_CONSTANT
)
745 result
= gfc_get_constant_expr (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
746 mpz_abs (result
->value
.integer
, e
->value
.integer
);
747 return range_check (result
, "IABS");
750 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
751 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
752 return range_check (result
, "ABS");
755 gfc_set_model_kind (e
->ts
.kind
);
756 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
757 mpc_abs (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
758 return range_check (result
, "CABS");
761 gfc_internal_error ("gfc_simplify_abs(): Bad type");
767 simplify_achar_char (gfc_expr
*e
, gfc_expr
*k
, const char *name
, bool ascii
)
771 bool too_large
= false;
773 if (e
->expr_type
!= EXPR_CONSTANT
)
776 kind
= get_kind (BT_CHARACTER
, k
, name
, gfc_default_character_kind
);
778 return &gfc_bad_expr
;
780 if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
782 gfc_error ("Argument of %s function at %L is negative", name
,
784 return &gfc_bad_expr
;
787 if (ascii
&& warn_surprising
&& mpz_cmp_si (e
->value
.integer
, 127) > 0)
788 gfc_warning (OPT_Wsurprising
,
789 "Argument of %s function at %L outside of range [0,127]",
792 if (kind
== 1 && mpz_cmp_si (e
->value
.integer
, 255) > 0)
797 mpz_init_set_ui (t
, 2);
798 mpz_pow_ui (t
, t
, 32);
799 mpz_sub_ui (t
, t
, 1);
800 if (mpz_cmp (e
->value
.integer
, t
) > 0)
807 gfc_error ("Argument of %s function at %L is too large for the "
808 "collating sequence of kind %d", name
, &e
->where
, kind
);
809 return &gfc_bad_expr
;
812 result
= gfc_get_character_expr (kind
, &e
->where
, NULL
, 1);
813 result
->value
.character
.string
[0] = mpz_get_ui (e
->value
.integer
);
820 /* We use the processor's collating sequence, because all
821 systems that gfortran currently works on are ASCII. */
824 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
826 return simplify_achar_char (e
, k
, "ACHAR", true);
831 gfc_simplify_acos (gfc_expr
*x
)
835 if (x
->expr_type
!= EXPR_CONSTANT
)
841 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
842 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
844 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
846 return &gfc_bad_expr
;
848 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
849 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
853 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
854 mpc_acos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
858 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
861 return range_check (result
, "ACOS");
865 gfc_simplify_acosh (gfc_expr
*x
)
869 if (x
->expr_type
!= EXPR_CONSTANT
)
875 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
877 gfc_error ("Argument of ACOSH at %L must not be less than 1",
879 return &gfc_bad_expr
;
882 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
883 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
887 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
888 mpc_acosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
892 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
895 return range_check (result
, "ACOSH");
899 gfc_simplify_adjustl (gfc_expr
*e
)
905 if (e
->expr_type
!= EXPR_CONSTANT
)
908 len
= e
->value
.character
.length
;
910 for (count
= 0, i
= 0; i
< len
; ++i
)
912 ch
= e
->value
.character
.string
[i
];
918 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
919 for (i
= 0; i
< len
- count
; ++i
)
920 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
927 gfc_simplify_adjustr (gfc_expr
*e
)
933 if (e
->expr_type
!= EXPR_CONSTANT
)
936 len
= e
->value
.character
.length
;
938 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
940 ch
= e
->value
.character
.string
[i
];
946 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
947 for (i
= 0; i
< count
; ++i
)
948 result
->value
.character
.string
[i
] = ' ';
950 for (i
= count
; i
< len
; ++i
)
951 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
958 gfc_simplify_aimag (gfc_expr
*e
)
962 if (e
->expr_type
!= EXPR_CONSTANT
)
965 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
966 mpfr_set (result
->value
.real
, mpc_imagref (e
->value
.complex), GFC_RND_MODE
);
968 return range_check (result
, "AIMAG");
973 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
975 gfc_expr
*rtrunc
, *result
;
978 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
980 return &gfc_bad_expr
;
982 if (e
->expr_type
!= EXPR_CONSTANT
)
985 rtrunc
= gfc_copy_expr (e
);
986 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
988 result
= gfc_real2real (rtrunc
, kind
);
990 gfc_free_expr (rtrunc
);
992 return range_check (result
, "AINT");
997 gfc_simplify_all (gfc_expr
*mask
, gfc_expr
*dim
)
999 return simplify_transformation (mask
, dim
, NULL
, true, gfc_and
);
1004 gfc_simplify_dint (gfc_expr
*e
)
1006 gfc_expr
*rtrunc
, *result
;
1008 if (e
->expr_type
!= EXPR_CONSTANT
)
1011 rtrunc
= gfc_copy_expr (e
);
1012 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1014 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
1016 gfc_free_expr (rtrunc
);
1018 return range_check (result
, "DINT");
1023 gfc_simplify_dreal (gfc_expr
*e
)
1025 gfc_expr
*result
= NULL
;
1027 if (e
->expr_type
!= EXPR_CONSTANT
)
1030 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
1031 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
1033 return range_check (result
, "DREAL");
1038 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
1043 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
1045 return &gfc_bad_expr
;
1047 if (e
->expr_type
!= EXPR_CONSTANT
)
1050 result
= gfc_get_constant_expr (e
->ts
.type
, kind
, &e
->where
);
1051 mpfr_round (result
->value
.real
, e
->value
.real
);
1053 return range_check (result
, "ANINT");
1058 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
1063 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1066 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1071 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
1072 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1073 return range_check (result
, "AND");
1076 return gfc_get_logical_expr (kind
, &x
->where
,
1077 x
->value
.logical
&& y
->value
.logical
);
1086 gfc_simplify_any (gfc_expr
*mask
, gfc_expr
*dim
)
1088 return simplify_transformation (mask
, dim
, NULL
, false, gfc_or
);
1093 gfc_simplify_dnint (gfc_expr
*e
)
1097 if (e
->expr_type
!= EXPR_CONSTANT
)
1100 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &e
->where
);
1101 mpfr_round (result
->value
.real
, e
->value
.real
);
1103 return range_check (result
, "DNINT");
1108 gfc_simplify_asin (gfc_expr
*x
)
1112 if (x
->expr_type
!= EXPR_CONSTANT
)
1118 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1119 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1121 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1123 return &gfc_bad_expr
;
1125 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1126 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1130 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1131 mpc_asin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1135 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1138 return range_check (result
, "ASIN");
1142 /* Convert radians to degrees, i.e., x * 180 / pi. */
1150 mpfr_const_pi (tmp
, GFC_RND_MODE
);
1151 mpfr_mul_ui (x
, x
, 180, GFC_RND_MODE
);
1152 mpfr_div (x
, x
, tmp
, GFC_RND_MODE
);
1157 /* Simplify ACOSD(X) where the returned value has units of degree. */
1160 gfc_simplify_acosd (gfc_expr
*x
)
1164 if (x
->expr_type
!= EXPR_CONSTANT
)
1167 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1168 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1170 gfc_error ("Argument of ACOSD at %L must be between -1 and 1",
1172 return &gfc_bad_expr
;
1175 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1176 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1177 rad2deg (result
->value
.real
);
1179 return range_check (result
, "ACOSD");
1183 /* Simplify asind (x) where the returned value has units of degree. */
1186 gfc_simplify_asind (gfc_expr
*x
)
1190 if (x
->expr_type
!= EXPR_CONSTANT
)
1193 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1194 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1196 gfc_error ("Argument of ASIND at %L must be between -1 and 1",
1198 return &gfc_bad_expr
;
1201 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1202 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1203 rad2deg (result
->value
.real
);
1205 return range_check (result
, "ASIND");
1209 /* Simplify atand (x) where the returned value has units of degree. */
1212 gfc_simplify_atand (gfc_expr
*x
)
1216 if (x
->expr_type
!= EXPR_CONSTANT
)
1219 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1220 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1221 rad2deg (result
->value
.real
);
1223 return range_check (result
, "ATAND");
1228 gfc_simplify_asinh (gfc_expr
*x
)
1232 if (x
->expr_type
!= EXPR_CONSTANT
)
1235 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1240 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1244 mpc_asinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1248 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1251 return range_check (result
, "ASINH");
1256 gfc_simplify_atan (gfc_expr
*x
)
1260 if (x
->expr_type
!= EXPR_CONSTANT
)
1263 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1268 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1272 mpc_atan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1276 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1279 return range_check (result
, "ATAN");
1284 gfc_simplify_atanh (gfc_expr
*x
)
1288 if (x
->expr_type
!= EXPR_CONSTANT
)
1294 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
1295 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
1297 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1299 return &gfc_bad_expr
;
1301 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1302 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1306 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1307 mpc_atanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1311 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1314 return range_check (result
, "ATANH");
1319 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1323 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1326 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1328 gfc_error ("If first argument of ATAN2 at %L is zero, then the "
1329 "second argument must not be zero", &y
->where
);
1330 return &gfc_bad_expr
;
1333 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1334 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1336 return range_check (result
, "ATAN2");
1341 gfc_simplify_bessel_j0 (gfc_expr
*x
)
1345 if (x
->expr_type
!= EXPR_CONSTANT
)
1348 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1349 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1351 return range_check (result
, "BESSEL_J0");
1356 gfc_simplify_bessel_j1 (gfc_expr
*x
)
1360 if (x
->expr_type
!= EXPR_CONSTANT
)
1363 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1364 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1366 return range_check (result
, "BESSEL_J1");
1371 gfc_simplify_bessel_jn (gfc_expr
*order
, gfc_expr
*x
)
1376 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1379 n
= mpz_get_si (order
->value
.integer
);
1380 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1381 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1383 return range_check (result
, "BESSEL_JN");
1387 /* Simplify transformational form of JN and YN. */
1390 gfc_simplify_bessel_n2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
,
1397 mpfr_t x2rev
, last1
, last2
;
1399 if (x
->expr_type
!= EXPR_CONSTANT
|| order1
->expr_type
!= EXPR_CONSTANT
1400 || order2
->expr_type
!= EXPR_CONSTANT
)
1403 n1
= mpz_get_si (order1
->value
.integer
);
1404 n2
= mpz_get_si (order2
->value
.integer
);
1405 result
= gfc_get_array_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1407 result
->shape
= gfc_get_shape (1);
1408 mpz_init_set_ui (result
->shape
[0], MAX (n2
-n1
+1, 0));
1413 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1414 YN(N, 0.0) = -Inf. */
1416 if (mpfr_cmp_ui (x
->value
.real
, 0.0) == 0)
1418 if (!jn
&& flag_range_check
)
1420 gfc_error ("Result of BESSEL_YN is -INF at %L", &result
->where
);
1421 gfc_free_expr (result
);
1422 return &gfc_bad_expr
;
1427 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1428 mpfr_set_ui (e
->value
.real
, 1, GFC_RND_MODE
);
1429 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1434 for (i
= n1
; i
<= n2
; i
++)
1436 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1438 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
1440 mpfr_set_inf (e
->value
.real
, -1);
1441 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1448 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1449 are stable for downward recursion and Neumann functions are stable
1450 for upward recursion. It is
1452 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1453 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1454 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1456 gfc_set_model_kind (x
->ts
.kind
);
1458 /* Get first recursion anchor. */
1462 mpfr_jn (last1
, n2
, x
->value
.real
, GFC_RND_MODE
);
1464 mpfr_yn (last1
, n1
, x
->value
.real
, GFC_RND_MODE
);
1466 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1467 mpfr_set (e
->value
.real
, last1
, GFC_RND_MODE
);
1468 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1472 gfc_free_expr (result
);
1473 return &gfc_bad_expr
;
1475 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1483 /* Get second recursion anchor. */
1487 mpfr_jn (last2
, n2
-1, x
->value
.real
, GFC_RND_MODE
);
1489 mpfr_yn (last2
, n1
+1, x
->value
.real
, GFC_RND_MODE
);
1491 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1492 mpfr_set (e
->value
.real
, last2
, GFC_RND_MODE
);
1493 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1498 gfc_free_expr (result
);
1499 return &gfc_bad_expr
;
1502 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
, -2);
1504 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1513 /* Start actual recursion. */
1516 mpfr_ui_div (x2rev
, 2, x
->value
.real
, GFC_RND_MODE
);
1518 for (i
= 2; i
<= n2
-n1
; i
++)
1520 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1522 /* Special case: For YN, if the previous N gave -INF, set
1523 also N+1 to -INF. */
1524 if (!jn
&& !flag_range_check
&& mpfr_inf_p (last2
))
1526 mpfr_set_inf (e
->value
.real
, -1);
1527 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1532 mpfr_mul_si (e
->value
.real
, x2rev
, jn
? (n2
-i
+1) : (n1
+i
-1),
1534 mpfr_mul (e
->value
.real
, e
->value
.real
, last2
, GFC_RND_MODE
);
1535 mpfr_sub (e
->value
.real
, e
->value
.real
, last1
, GFC_RND_MODE
);
1537 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1539 /* Range_check frees "e" in that case. */
1545 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
,
1548 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1550 mpfr_set (last1
, last2
, GFC_RND_MODE
);
1551 mpfr_set (last2
, e
->value
.real
, GFC_RND_MODE
);
1564 gfc_free_expr (result
);
1565 return &gfc_bad_expr
;
1570 gfc_simplify_bessel_jn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1572 return gfc_simplify_bessel_n2 (order1
, order2
, x
, true);
1577 gfc_simplify_bessel_y0 (gfc_expr
*x
)
1581 if (x
->expr_type
!= EXPR_CONSTANT
)
1584 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1585 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1587 return range_check (result
, "BESSEL_Y0");
1592 gfc_simplify_bessel_y1 (gfc_expr
*x
)
1596 if (x
->expr_type
!= EXPR_CONSTANT
)
1599 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1600 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1602 return range_check (result
, "BESSEL_Y1");
1607 gfc_simplify_bessel_yn (gfc_expr
*order
, gfc_expr
*x
)
1612 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1615 n
= mpz_get_si (order
->value
.integer
);
1616 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1617 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1619 return range_check (result
, "BESSEL_YN");
1624 gfc_simplify_bessel_yn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1626 return gfc_simplify_bessel_n2 (order1
, order2
, x
, false);
1631 gfc_simplify_bit_size (gfc_expr
*e
)
1633 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1634 return gfc_get_int_expr (e
->ts
.kind
, &e
->where
,
1635 gfc_integer_kinds
[i
].bit_size
);
1640 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
1644 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
1647 if (gfc_extract_int (bit
, &b
) || b
< 0)
1648 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
, false);
1650 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
,
1651 mpz_tstbit (e
->value
.integer
, b
));
1656 compare_bitwise (gfc_expr
*i
, gfc_expr
*j
)
1661 gcc_assert (i
->ts
.type
== BT_INTEGER
);
1662 gcc_assert (j
->ts
.type
== BT_INTEGER
);
1664 mpz_init_set (x
, i
->value
.integer
);
1665 k
= gfc_validate_kind (i
->ts
.type
, i
->ts
.kind
, false);
1666 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
1668 mpz_init_set (y
, j
->value
.integer
);
1669 k
= gfc_validate_kind (j
->ts
.type
, j
->ts
.kind
, false);
1670 convert_mpz_to_unsigned (y
, gfc_integer_kinds
[k
].bit_size
);
1672 res
= mpz_cmp (x
, y
);
1680 gfc_simplify_bge (gfc_expr
*i
, gfc_expr
*j
)
1682 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1685 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1686 compare_bitwise (i
, j
) >= 0);
1691 gfc_simplify_bgt (gfc_expr
*i
, gfc_expr
*j
)
1693 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1696 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1697 compare_bitwise (i
, j
) > 0);
1702 gfc_simplify_ble (gfc_expr
*i
, gfc_expr
*j
)
1704 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1707 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1708 compare_bitwise (i
, j
) <= 0);
1713 gfc_simplify_blt (gfc_expr
*i
, gfc_expr
*j
)
1715 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1718 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1719 compare_bitwise (i
, j
) < 0);
1724 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
1726 gfc_expr
*ceil
, *result
;
1729 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
1731 return &gfc_bad_expr
;
1733 if (e
->expr_type
!= EXPR_CONSTANT
)
1736 ceil
= gfc_copy_expr (e
);
1737 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
1739 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
1740 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
, &e
->where
);
1742 gfc_free_expr (ceil
);
1744 return range_check (result
, "CEILING");
1749 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
1751 return simplify_achar_char (e
, k
, "CHAR", false);
1755 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1758 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
1762 if (x
->expr_type
!= EXPR_CONSTANT
1763 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1766 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &x
->where
);
1771 mpc_set_z (result
->value
.complex, x
->value
.integer
, GFC_MPC_RND_MODE
);
1775 mpc_set_fr (result
->value
.complex, x
->value
.real
, GFC_RND_MODE
);
1779 mpc_set (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1783 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1787 return range_check (result
, name
);
1792 mpfr_set_z (mpc_imagref (result
->value
.complex),
1793 y
->value
.integer
, GFC_RND_MODE
);
1797 mpfr_set (mpc_imagref (result
->value
.complex),
1798 y
->value
.real
, GFC_RND_MODE
);
1802 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1805 return range_check (result
, name
);
1810 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
1814 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_complex_kind
);
1816 return &gfc_bad_expr
;
1818 return simplify_cmplx ("CMPLX", x
, y
, kind
);
1823 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
1827 if (x
->ts
.type
== BT_INTEGER
&& y
->ts
.type
== BT_INTEGER
)
1828 kind
= gfc_default_complex_kind
;
1829 else if (x
->ts
.type
== BT_REAL
|| y
->ts
.type
== BT_INTEGER
)
1831 else if (x
->ts
.type
== BT_INTEGER
|| y
->ts
.type
== BT_REAL
)
1833 else if (x
->ts
.type
== BT_REAL
&& y
->ts
.type
== BT_REAL
)
1834 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
1838 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1843 gfc_simplify_conjg (gfc_expr
*e
)
1847 if (e
->expr_type
!= EXPR_CONSTANT
)
1850 result
= gfc_copy_expr (e
);
1851 mpc_conj (result
->value
.complex, result
->value
.complex, GFC_MPC_RND_MODE
);
1853 return range_check (result
, "CONJG");
1857 /* Simplify atan2d (x) where the unit is degree. */
1860 gfc_simplify_atan2d (gfc_expr
*y
, gfc_expr
*x
)
1864 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1867 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1869 gfc_error ("If first argument of ATAN2D at %L is zero, then the "
1870 "second argument must not be zero", &y
->where
);
1871 return &gfc_bad_expr
;
1874 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1875 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1876 rad2deg (result
->value
.real
);
1878 return range_check (result
, "ATAN2D");
1883 gfc_simplify_cos (gfc_expr
*x
)
1887 if (x
->expr_type
!= EXPR_CONSTANT
)
1890 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1895 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1899 gfc_set_model_kind (x
->ts
.kind
);
1900 mpc_cos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1904 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1907 return range_check (result
, "COS");
1917 mpfr_const_pi (d2r
, GFC_RND_MODE
);
1918 mpfr_div_ui (d2r
, d2r
, 180, GFC_RND_MODE
);
1919 mpfr_mul (x
, x
, d2r
, GFC_RND_MODE
);
1924 /* Simplification routines for SIND, COSD, TAND. */
1925 #include "trigd_fe.inc"
1928 /* Simplify COSD(X) where X has the unit of degree. */
1931 gfc_simplify_cosd (gfc_expr
*x
)
1935 if (x
->expr_type
!= EXPR_CONSTANT
)
1938 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1939 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1940 simplify_cosd (result
->value
.real
);
1942 return range_check (result
, "COSD");
1946 /* Simplify SIND(X) where X has the unit of degree. */
1949 gfc_simplify_sind (gfc_expr
*x
)
1953 if (x
->expr_type
!= EXPR_CONSTANT
)
1956 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1957 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1958 simplify_sind (result
->value
.real
);
1960 return range_check (result
, "SIND");
1964 /* Simplify TAND(X) where X has the unit of degree. */
1967 gfc_simplify_tand (gfc_expr
*x
)
1971 if (x
->expr_type
!= EXPR_CONSTANT
)
1974 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1975 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1976 simplify_tand (result
->value
.real
);
1978 return range_check (result
, "TAND");
1982 /* Simplify COTAND(X) where X has the unit of degree. */
1985 gfc_simplify_cotand (gfc_expr
*x
)
1989 if (x
->expr_type
!= EXPR_CONSTANT
)
1992 /* Implement COTAND = -TAND(x+90).
1993 TAND offers correct exact values for multiples of 30 degrees.
1994 This implementation is also compatible with the behavior of some legacy
1995 compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */
1996 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1997 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1998 mpfr_add_ui (result
->value
.real
, result
->value
.real
, 90, GFC_RND_MODE
);
1999 simplify_tand (result
->value
.real
);
2000 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
2002 return range_check (result
, "COTAND");
2007 gfc_simplify_cosh (gfc_expr
*x
)
2011 if (x
->expr_type
!= EXPR_CONSTANT
)
2014 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2019 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2023 mpc_cosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2030 return range_check (result
, "COSH");
2035 gfc_simplify_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
2040 size_zero
= gfc_is_size_zero_array (mask
);
2042 if (!(is_constant_array_expr (mask
) || size_zero
)
2043 || !gfc_is_constant_expr (dim
)
2044 || !gfc_is_constant_expr (kind
))
2047 result
= transformational_result (mask
, dim
,
2049 get_kind (BT_INTEGER
, kind
, "COUNT",
2050 gfc_default_integer_kind
),
2053 init_result_expr (result
, 0, NULL
);
2058 /* Passing MASK twice, once as data array, once as mask.
2059 Whenever gfc_count is called, '1' is added to the result. */
2060 return !dim
|| mask
->rank
== 1 ?
2061 simplify_transformation_to_scalar (result
, mask
, mask
, gfc_count
) :
2062 simplify_transformation_to_array (result
, mask
, dim
, mask
, gfc_count
, NULL
);
2065 /* Simplification routine for cshift. This works by copying the array
2066 expressions into a one-dimensional array, shuffling the values into another
2067 one-dimensional array and creating the new array expression from this. The
2068 shuffling part is basically taken from the library routine. */
2071 gfc_simplify_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
2075 gfc_expr
**arrayvec
, **resultvec
;
2076 gfc_expr
**rptr
, **sptr
;
2078 size_t arraysize
, shiftsize
, i
;
2079 gfc_constructor
*array_ctor
, *shift_ctor
;
2080 ssize_t
*shiftvec
, *hptr
;
2081 ssize_t shift_val
, len
;
2082 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
2083 hs_ex
[GFC_MAX_DIMENSIONS
+ 1],
2084 hstride
[GFC_MAX_DIMENSIONS
], sstride
[GFC_MAX_DIMENSIONS
],
2085 a_extent
[GFC_MAX_DIMENSIONS
], a_stride
[GFC_MAX_DIMENSIONS
],
2086 h_extent
[GFC_MAX_DIMENSIONS
],
2087 ss_ex
[GFC_MAX_DIMENSIONS
+ 1];
2091 gfc_expr
**src
, **dest
;
2093 if (!is_constant_array_expr (array
))
2096 if (shift
->rank
> 0)
2097 gfc_simplify_expr (shift
, 1);
2099 if (!gfc_is_constant_expr (shift
))
2102 /* Make dim zero-based. */
2105 if (!gfc_is_constant_expr (dim
))
2107 which
= mpz_get_si (dim
->value
.integer
) - 1;
2112 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
);
2140 for (d
=0; d
< array
->rank
; d
++)
2142 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2143 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2146 if (shift
->rank
> 0)
2148 gfc_array_size (shift
, &size
);
2149 shiftsize
= mpz_get_ui (size
);
2151 shiftvec
= XCNEWVEC (ssize_t
, shiftsize
);
2152 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2153 for (d
= 0; d
< shift
->rank
; d
++)
2155 h_extent
[d
] = mpz_get_si (shift
->shape
[d
]);
2156 hstride
[d
] = d
== 0 ? 1 : hstride
[d
-1] * h_extent
[d
-1];
2162 /* Shut up compiler */
2167 for (d
=0; d
< array
->rank
; d
++)
2171 rsoffset
= a_stride
[d
];
2177 extent
[n
] = a_extent
[d
];
2178 sstride
[n
] = a_stride
[d
];
2179 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2181 hs_ex
[n
] = hstride
[n
] * extent
[n
];
2190 for (i
= 0; i
< shiftsize
; i
++)
2193 val
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2198 shift_ctor
= gfc_constructor_next (shift_ctor
);
2204 shift_val
= mpz_get_si (shift
->value
.integer
);
2205 shift_val
= shift_val
% len
;
2210 continue_loop
= true;
2216 while (continue_loop
)
2224 src
= &sptr
[sh
* rsoffset
];
2226 for (n
= 0; n
< len
- sh
; n
++)
2233 for ( n
= 0; n
< sh
; n
++)
2245 while (count
[n
] == extent
[n
])
2255 continue_loop
= false;
2269 for (i
= 0; i
< arraysize
; i
++)
2271 gfc_constructor_append_expr (&result
->value
.constructor
,
2272 gfc_copy_expr (resultvec
[i
]),
2280 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2282 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
2287 gfc_simplify_dble (gfc_expr
*e
)
2289 gfc_expr
*result
= NULL
;
2292 if (e
->expr_type
!= EXPR_CONSTANT
)
2295 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
2297 tmp1
= warn_conversion
;
2298 tmp2
= warn_conversion_extra
;
2299 warn_conversion
= warn_conversion_extra
= 0;
2301 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
2303 warn_conversion
= tmp1
;
2304 warn_conversion_extra
= tmp2
;
2306 if (result
== &gfc_bad_expr
)
2307 return &gfc_bad_expr
;
2309 return range_check (result
, "DBLE");
2314 gfc_simplify_digits (gfc_expr
*x
)
2318 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2323 digits
= gfc_integer_kinds
[i
].digits
;
2328 digits
= gfc_real_kinds
[i
].digits
;
2335 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
2340 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
2345 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2348 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2349 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
2354 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
2355 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2357 mpz_set_ui (result
->value
.integer
, 0);
2362 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
2363 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
2366 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2371 gfc_internal_error ("gfc_simplify_dim(): Bad type");
2374 return range_check (result
, "DIM");
2379 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2381 /* If vector_a is a zero-sized array, the result is 0 for INTEGER,
2382 REAL, and COMPLEX types and .false. for LOGICAL. */
2383 if (vector_a
->shape
&& mpz_get_si (vector_a
->shape
[0]) == 0)
2385 if (vector_a
->ts
.type
== BT_LOGICAL
)
2386 return gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, false);
2388 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2391 if (!is_constant_array_expr (vector_a
)
2392 || !is_constant_array_expr (vector_b
))
2395 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
2400 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
2402 gfc_expr
*a1
, *a2
, *result
;
2404 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2407 a1
= gfc_real2real (x
, gfc_default_double_kind
);
2408 a2
= gfc_real2real (y
, gfc_default_double_kind
);
2410 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
2411 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
2416 return range_check (result
, "DPROD");
2421 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
2425 int i
, k
, size
, shift
;
2427 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
2428 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
2431 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
2432 size
= gfc_integer_kinds
[k
].bit_size
;
2434 gfc_extract_int (shiftarg
, &shift
);
2436 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2438 shift
= size
- shift
;
2440 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
2441 mpz_set_ui (result
->value
.integer
, 0);
2443 for (i
= 0; i
< shift
; i
++)
2444 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
2445 mpz_setbit (result
->value
.integer
, i
);
2447 for (i
= 0; i
< size
- shift
; i
++)
2448 if (mpz_tstbit (arg1
->value
.integer
, i
))
2449 mpz_setbit (result
->value
.integer
, shift
+ i
);
2451 /* Convert to a signed value. */
2452 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
2459 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2461 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
2466 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2468 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
2473 gfc_simplify_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2480 gfc_expr
**arrayvec
, **resultvec
;
2481 gfc_expr
**rptr
, **sptr
;
2483 size_t arraysize
, i
;
2484 gfc_constructor
*array_ctor
, *shift_ctor
, *bnd_ctor
;
2485 ssize_t shift_val
, len
;
2486 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
2487 sstride
[GFC_MAX_DIMENSIONS
], a_extent
[GFC_MAX_DIMENSIONS
],
2488 a_stride
[GFC_MAX_DIMENSIONS
], ss_ex
[GFC_MAX_DIMENSIONS
+ 1];
2492 gfc_expr
**src
, **dest
;
2495 if (!is_constant_array_expr (array
))
2498 if (shift
->rank
> 0)
2499 gfc_simplify_expr (shift
, 1);
2501 if (!gfc_is_constant_expr (shift
))
2506 if (boundary
->rank
> 0)
2507 gfc_simplify_expr (boundary
, 1);
2509 if (!gfc_is_constant_expr (boundary
))
2515 if (!gfc_is_constant_expr (dim
))
2517 which
= mpz_get_si (dim
->value
.integer
) - 1;
2523 if (boundary
== NULL
)
2525 temp_boundary
= true;
2526 switch (array
->ts
.type
)
2530 bnd
= gfc_get_int_expr (array
->ts
.kind
, NULL
, 0);
2534 bnd
= gfc_get_logical_expr (array
->ts
.kind
, NULL
, 0);
2538 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2539 mpfr_set_ui (bnd
->value
.real
, 0, GFC_RND_MODE
);
2543 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2544 mpc_set_ui (bnd
->value
.complex, 0, GFC_RND_MODE
);
2548 s_len
= mpz_get_ui (array
->ts
.u
.cl
->length
->value
.integer
);
2549 bnd
= gfc_get_character_expr (array
->ts
.kind
, &gfc_current_locus
, NULL
, s_len
);
2559 temp_boundary
= false;
2563 gfc_array_size (array
, &size
);
2564 arraysize
= mpz_get_ui (size
);
2567 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
2568 result
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
2569 result
->rank
= array
->rank
;
2570 result
->ts
= array
->ts
;
2575 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2576 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
2577 for (i
= 0; i
< arraysize
; i
++)
2579 arrayvec
[i
] = array_ctor
->expr
;
2580 array_ctor
= gfc_constructor_next (array_ctor
);
2583 resultvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2588 for (d
=0; d
< array
->rank
; d
++)
2590 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2591 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2594 if (shift
->rank
> 0)
2596 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2602 shift_val
= mpz_get_si (shift
->value
.integer
);
2606 bnd_ctor
= gfc_constructor_first (bnd
->value
.constructor
);
2610 /* Shut up compiler */
2615 for (d
=0; d
< array
->rank
; d
++)
2619 rsoffset
= a_stride
[d
];
2625 extent
[n
] = a_extent
[d
];
2626 sstride
[n
] = a_stride
[d
];
2627 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2633 continue_loop
= true;
2638 while (continue_loop
)
2643 sh
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2647 if (( sh
>= 0 ? sh
: -sh
) > len
)
2653 delta
= (sh
>= 0) ? sh
: -sh
;
2657 src
= &sptr
[delta
* rsoffset
];
2663 dest
= &rptr
[delta
* rsoffset
];
2666 for (n
= 0; n
< len
- delta
; n
++)
2682 *dest
= gfc_copy_expr (bnd_ctor
->expr
);
2690 *dest
= gfc_copy_expr (bnd
);
2697 shift_ctor
= gfc_constructor_next (shift_ctor
);
2700 bnd_ctor
= gfc_constructor_next (bnd_ctor
);
2704 while (count
[n
] == extent
[n
])
2712 continue_loop
= false;
2724 for (i
= 0; i
< arraysize
; i
++)
2726 gfc_constructor_append_expr (&result
->value
.constructor
,
2727 gfc_copy_expr (resultvec
[i
]),
2733 gfc_free_expr (bnd
);
2739 gfc_simplify_erf (gfc_expr
*x
)
2743 if (x
->expr_type
!= EXPR_CONSTANT
)
2746 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2747 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2749 return range_check (result
, "ERF");
2754 gfc_simplify_erfc (gfc_expr
*x
)
2758 if (x
->expr_type
!= EXPR_CONSTANT
)
2761 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2762 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2764 return range_check (result
, "ERFC");
2768 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2770 #define MAX_ITER 200
2771 #define ARG_LIMIT 12
2773 /* Calculate ERFC_SCALED directly by its definition:
2775 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2777 using a large precision for intermediate results. This is used for all
2778 but large values of the argument. */
2780 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2785 prec
= mpfr_get_default_prec ();
2786 mpfr_set_default_prec (10 * prec
);
2791 mpfr_set (a
, arg
, GFC_RND_MODE
);
2792 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2793 mpfr_exp (b
, b
, GFC_RND_MODE
);
2794 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2795 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2797 mpfr_set (res
, a
, GFC_RND_MODE
);
2798 mpfr_set_default_prec (prec
);
2804 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2806 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2807 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2810 This is used for large values of the argument. Intermediate calculations
2811 are performed with twice the precision. We don't do a fixed number of
2812 iterations of the sum, but stop when it has converged to the required
2815 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2817 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2822 prec
= mpfr_get_default_prec ();
2823 mpfr_set_default_prec (2 * prec
);
2833 mpfr_init (sumtrunc
);
2834 mpfr_set_prec (oldsum
, prec
);
2835 mpfr_set_prec (sumtrunc
, prec
);
2837 mpfr_set (x
, arg
, GFC_RND_MODE
);
2838 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2839 mpz_set_ui (num
, 1);
2841 mpfr_set (u
, x
, GFC_RND_MODE
);
2842 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2843 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2844 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2846 for (i
= 1; i
< MAX_ITER
; i
++)
2848 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2850 mpz_mul_ui (num
, num
, 2 * i
- 1);
2853 mpfr_set (w
, u
, GFC_RND_MODE
);
2854 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2856 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2857 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2859 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2861 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2862 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2866 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2868 gcc_assert (i
< MAX_ITER
);
2870 /* Divide by x * sqrt(Pi). */
2871 mpfr_const_pi (u
, GFC_RND_MODE
);
2872 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2873 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2874 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2876 mpfr_set (res
, sum
, GFC_RND_MODE
);
2877 mpfr_set_default_prec (prec
);
2879 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2885 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2889 if (x
->expr_type
!= EXPR_CONSTANT
)
2892 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2893 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2894 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2896 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2898 return range_check (result
, "ERFC_SCALED");
2906 gfc_simplify_epsilon (gfc_expr
*e
)
2911 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2913 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2914 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2916 return range_check (result
, "EPSILON");
2921 gfc_simplify_exp (gfc_expr
*x
)
2925 if (x
->expr_type
!= EXPR_CONSTANT
)
2928 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2933 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2937 gfc_set_model_kind (x
->ts
.kind
);
2938 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2942 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2945 return range_check (result
, "EXP");
2950 gfc_simplify_exponent (gfc_expr
*x
)
2955 if (x
->expr_type
!= EXPR_CONSTANT
)
2958 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2961 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2962 if (mpfr_inf_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
2964 int i
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
2965 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2969 /* EXPONENT(+/- 0.0) = 0 */
2970 if (mpfr_zero_p (x
->value
.real
))
2972 mpz_set_ui (result
->value
.integer
, 0);
2976 gfc_set_model (x
->value
.real
);
2978 val
= (long int) mpfr_get_exp (x
->value
.real
);
2979 mpz_set_si (result
->value
.integer
, val
);
2981 return range_check (result
, "EXPONENT");
2986 gfc_simplify_failed_or_stopped_images (gfc_expr
*team ATTRIBUTE_UNUSED
,
2989 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2991 gfc_current_locus
= *gfc_current_intrinsic_where
;
2992 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2993 return &gfc_bad_expr
;
2996 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
3001 gfc_extract_int (kind
, &actual_kind
);
3003 actual_kind
= gfc_default_integer_kind
;
3005 result
= gfc_get_array_expr (BT_INTEGER
, actual_kind
, &gfc_current_locus
);
3010 /* For fcoarray = lib no simplification is possible, because it is not known
3011 what images failed or are stopped at compile time. */
3017 gfc_simplify_get_team (gfc_expr
*level ATTRIBUTE_UNUSED
)
3019 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3021 gfc_current_locus
= *gfc_current_intrinsic_where
;
3022 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3023 return &gfc_bad_expr
;
3026 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
3029 result
= gfc_get_array_expr (BT_INTEGER
, gfc_default_integer_kind
, &gfc_current_locus
);
3034 /* For fcoarray = lib no simplification is possible, because it is not known
3035 what images failed or are stopped at compile time. */
3041 gfc_simplify_float (gfc_expr
*a
)
3045 if (a
->expr_type
!= EXPR_CONSTANT
)
3048 result
= gfc_int2real (a
, gfc_default_real_kind
);
3050 return range_check (result
, "FLOAT");
3055 is_last_ref_vtab (gfc_expr
*e
)
3058 gfc_component
*comp
= NULL
;
3060 if (e
->expr_type
!= EXPR_VARIABLE
)
3063 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3064 if (ref
->type
== REF_COMPONENT
)
3065 comp
= ref
->u
.c
.component
;
3067 if (!e
->ref
|| !comp
)
3068 return e
->symtree
->n
.sym
->attr
.vtab
;
3070 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
3078 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
3080 /* Avoid simplification of resolved symbols. */
3081 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
3084 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
3085 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3086 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3089 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
3092 /* Return .false. if the dynamic type can never be an extension. */
3093 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
3094 && !gfc_type_is_extension_of
3095 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
3096 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
3097 && !gfc_type_is_extension_of
3098 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
3099 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
3100 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
3101 && !gfc_type_is_extension_of
3102 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
3104 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3105 && !gfc_type_is_extension_of
3106 (mold
->ts
.u
.derived
,
3107 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
3108 && !gfc_type_is_extension_of
3109 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
3110 mold
->ts
.u
.derived
)))
3111 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3113 /* Return .true. if the dynamic type is guaranteed to be an extension. */
3114 if (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3115 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3116 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
3117 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
3124 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3126 /* Avoid simplification of resolved symbols. */
3127 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
3130 /* Return .false. if the dynamic type can never be the
3132 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
3133 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
3134 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
3135 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
3136 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3138 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
3141 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3142 gfc_compare_derived_types (a
->ts
.u
.derived
,
3148 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
3154 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
3156 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3158 if (e
->expr_type
!= EXPR_CONSTANT
)
3161 mpfr_init2 (floor
, mpfr_get_prec (e
->value
.real
));
3162 mpfr_floor (floor
, e
->value
.real
);
3164 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
3165 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
3169 return range_check (result
, "FLOOR");
3174 gfc_simplify_fraction (gfc_expr
*x
)
3179 if (x
->expr_type
!= EXPR_CONSTANT
)
3182 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
3184 /* FRACTION(inf) = NaN. */
3185 if (mpfr_inf_p (x
->value
.real
))
3187 mpfr_set_nan (result
->value
.real
);
3191 /* mpfr_frexp() correctly handles zeros and NaNs. */
3192 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3194 return range_check (result
, "FRACTION");
3199 gfc_simplify_gamma (gfc_expr
*x
)
3203 if (x
->expr_type
!= EXPR_CONSTANT
)
3206 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3207 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3209 return range_check (result
, "GAMMA");
3214 gfc_simplify_huge (gfc_expr
*e
)
3219 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3220 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3225 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
3229 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
3241 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
3245 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3248 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3249 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
3250 return range_check (result
, "HYPOT");
3254 /* We use the processor's collating sequence, because all
3255 systems that gfortran currently works on are ASCII. */
3258 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
3264 if (e
->expr_type
!= EXPR_CONSTANT
)
3267 if (e
->value
.character
.length
!= 1)
3269 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
3270 return &gfc_bad_expr
;
3273 index
= e
->value
.character
.string
[0];
3275 if (warn_surprising
&& index
> 127)
3276 gfc_warning (OPT_Wsurprising
,
3277 "Argument of IACHAR function at %L outside of range 0..127",
3280 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
3282 return &gfc_bad_expr
;
3284 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3286 return range_check (result
, "IACHAR");
3291 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
3293 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3294 gcc_assert (result
->ts
.type
== BT_INTEGER
3295 && result
->expr_type
== EXPR_CONSTANT
);
3297 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3303 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3305 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
3310 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
3312 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3313 gcc_assert (result
->ts
.type
== BT_INTEGER
3314 && result
->expr_type
== EXPR_CONSTANT
);
3316 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3322 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3324 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
3329 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
3333 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3336 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3337 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3339 return range_check (result
, "IAND");
3344 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
3349 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3352 gfc_extract_int (y
, &pos
);
3354 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3356 result
= gfc_copy_expr (x
);
3358 convert_mpz_to_unsigned (result
->value
.integer
,
3359 gfc_integer_kinds
[k
].bit_size
);
3361 mpz_clrbit (result
->value
.integer
, pos
);
3363 gfc_convert_mpz_to_signed (result
->value
.integer
,
3364 gfc_integer_kinds
[k
].bit_size
);
3371 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
3378 if (x
->expr_type
!= EXPR_CONSTANT
3379 || y
->expr_type
!= EXPR_CONSTANT
3380 || z
->expr_type
!= EXPR_CONSTANT
)
3383 gfc_extract_int (y
, &pos
);
3384 gfc_extract_int (z
, &len
);
3386 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
3388 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3390 if (pos
+ len
> bitsize
)
3392 gfc_error ("Sum of second and third arguments of IBITS exceeds "
3393 "bit size at %L", &y
->where
);
3394 return &gfc_bad_expr
;
3397 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3398 convert_mpz_to_unsigned (result
->value
.integer
,
3399 gfc_integer_kinds
[k
].bit_size
);
3401 bits
= XCNEWVEC (int, bitsize
);
3403 for (i
= 0; i
< bitsize
; i
++)
3406 for (i
= 0; i
< len
; i
++)
3407 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
3409 for (i
= 0; i
< bitsize
; i
++)
3412 mpz_clrbit (result
->value
.integer
, i
);
3413 else if (bits
[i
] == 1)
3414 mpz_setbit (result
->value
.integer
, i
);
3416 gfc_internal_error ("IBITS: Bad bit");
3421 gfc_convert_mpz_to_signed (result
->value
.integer
,
3422 gfc_integer_kinds
[k
].bit_size
);
3429 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
3434 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3437 gfc_extract_int (y
, &pos
);
3439 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3441 result
= gfc_copy_expr (x
);
3443 convert_mpz_to_unsigned (result
->value
.integer
,
3444 gfc_integer_kinds
[k
].bit_size
);
3446 mpz_setbit (result
->value
.integer
, pos
);
3448 gfc_convert_mpz_to_signed (result
->value
.integer
,
3449 gfc_integer_kinds
[k
].bit_size
);
3456 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
3462 if (e
->expr_type
!= EXPR_CONSTANT
)
3465 if (e
->value
.character
.length
!= 1)
3467 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
3468 return &gfc_bad_expr
;
3471 index
= e
->value
.character
.string
[0];
3473 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
3475 return &gfc_bad_expr
;
3477 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3479 return range_check (result
, "ICHAR");
3484 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
3488 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3491 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3492 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3494 return range_check (result
, "IEOR");
3499 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
3502 int back
, len
, lensub
;
3503 int i
, j
, k
, count
, index
= 0, start
;
3505 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
3506 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
3509 if (b
!= NULL
&& b
->value
.logical
!= 0)
3514 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
3516 return &gfc_bad_expr
;
3518 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
3520 len
= x
->value
.character
.length
;
3521 lensub
= y
->value
.character
.length
;
3525 mpz_set_si (result
->value
.integer
, 0);
3533 mpz_set_si (result
->value
.integer
, 1);
3536 else if (lensub
== 1)
3538 for (i
= 0; i
< len
; i
++)
3540 for (j
= 0; j
< lensub
; j
++)
3542 if (y
->value
.character
.string
[j
]
3543 == x
->value
.character
.string
[i
])
3553 for (i
= 0; i
< len
; i
++)
3555 for (j
= 0; j
< lensub
; j
++)
3557 if (y
->value
.character
.string
[j
]
3558 == x
->value
.character
.string
[i
])
3563 for (k
= 0; k
< lensub
; k
++)
3565 if (y
->value
.character
.string
[k
]
3566 == x
->value
.character
.string
[k
+ start
])
3570 if (count
== lensub
)
3585 mpz_set_si (result
->value
.integer
, len
+ 1);
3588 else if (lensub
== 1)
3590 for (i
= 0; i
< len
; i
++)
3592 for (j
= 0; j
< lensub
; j
++)
3594 if (y
->value
.character
.string
[j
]
3595 == x
->value
.character
.string
[len
- i
])
3597 index
= len
- i
+ 1;
3605 for (i
= 0; i
< len
; i
++)
3607 for (j
= 0; j
< lensub
; j
++)
3609 if (y
->value
.character
.string
[j
]
3610 == x
->value
.character
.string
[len
- i
])
3613 if (start
<= len
- lensub
)
3616 for (k
= 0; k
< lensub
; k
++)
3617 if (y
->value
.character
.string
[k
]
3618 == x
->value
.character
.string
[k
+ start
])
3621 if (count
== lensub
)
3638 mpz_set_si (result
->value
.integer
, index
);
3639 return range_check (result
, "INDEX");
3644 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
3646 gfc_expr
*result
= NULL
;
3649 /* Convert BOZ to integer, and return without range checking. */
3650 if (e
->ts
.type
== BT_BOZ
)
3652 if (!gfc_boz2int (e
, kind
))
3654 result
= gfc_copy_expr (e
);
3658 if (e
->expr_type
!= EXPR_CONSTANT
)
3661 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
3663 tmp1
= warn_conversion
;
3664 tmp2
= warn_conversion_extra
;
3665 warn_conversion
= warn_conversion_extra
= 0;
3667 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
3669 warn_conversion
= tmp1
;
3670 warn_conversion_extra
= tmp2
;
3672 if (result
== &gfc_bad_expr
)
3673 return &gfc_bad_expr
;
3675 return range_check (result
, name
);
3680 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
3684 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
3686 return &gfc_bad_expr
;
3688 return simplify_intconv (e
, kind
, "INT");
3692 gfc_simplify_int2 (gfc_expr
*e
)
3694 return simplify_intconv (e
, 2, "INT2");
3699 gfc_simplify_int8 (gfc_expr
*e
)
3701 return simplify_intconv (e
, 8, "INT8");
3706 gfc_simplify_long (gfc_expr
*e
)
3708 return simplify_intconv (e
, 4, "LONG");
3713 gfc_simplify_ifix (gfc_expr
*e
)
3715 gfc_expr
*rtrunc
, *result
;
3717 if (e
->expr_type
!= EXPR_CONSTANT
)
3720 rtrunc
= gfc_copy_expr (e
);
3721 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3723 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3725 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3727 gfc_free_expr (rtrunc
);
3729 return range_check (result
, "IFIX");
3734 gfc_simplify_idint (gfc_expr
*e
)
3736 gfc_expr
*rtrunc
, *result
;
3738 if (e
->expr_type
!= EXPR_CONSTANT
)
3741 rtrunc
= gfc_copy_expr (e
);
3742 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3744 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3746 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3748 gfc_free_expr (rtrunc
);
3750 return range_check (result
, "IDINT");
3755 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
3759 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3762 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3763 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3765 return range_check (result
, "IOR");
3770 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
3772 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3773 gcc_assert (result
->ts
.type
== BT_INTEGER
3774 && result
->expr_type
== EXPR_CONSTANT
);
3776 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3782 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3784 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3789 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3791 if (x
->expr_type
!= EXPR_CONSTANT
)
3794 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3795 mpz_cmp_si (x
->value
.integer
,
3796 LIBERROR_END
) == 0);
3801 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3803 if (x
->expr_type
!= EXPR_CONSTANT
)
3806 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3807 mpz_cmp_si (x
->value
.integer
,
3808 LIBERROR_EOR
) == 0);
3813 gfc_simplify_isnan (gfc_expr
*x
)
3815 if (x
->expr_type
!= EXPR_CONSTANT
)
3818 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3819 mpfr_nan_p (x
->value
.real
));
3823 /* Performs a shift on its first argument. Depending on the last
3824 argument, the shift can be arithmetic, i.e. with filling from the
3825 left like in the SHIFTA intrinsic. */
3827 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3828 bool arithmetic
, int direction
)
3831 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3833 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3836 gfc_extract_int (s
, &shift
);
3838 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3839 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3841 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3845 mpz_set (result
->value
.integer
, e
->value
.integer
);
3849 if (direction
> 0 && shift
< 0)
3851 /* Left shift, as in SHIFTL. */
3852 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3853 return &gfc_bad_expr
;
3855 else if (direction
< 0)
3857 /* Right shift, as in SHIFTR or SHIFTA. */
3860 gfc_error ("Second argument of %s is negative at %L",
3862 return &gfc_bad_expr
;
3868 ashift
= (shift
>= 0 ? shift
: -shift
);
3870 if (ashift
> bitsize
)
3872 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3873 "at %L", name
, &e
->where
);
3874 return &gfc_bad_expr
;
3877 bits
= XCNEWVEC (int, bitsize
);
3879 for (i
= 0; i
< bitsize
; i
++)
3880 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3885 for (i
= 0; i
< shift
; i
++)
3886 mpz_clrbit (result
->value
.integer
, i
);
3888 for (i
= 0; i
< bitsize
- shift
; i
++)
3891 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3893 mpz_setbit (result
->value
.integer
, i
+ shift
);
3899 if (arithmetic
&& bits
[bitsize
- 1])
3900 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3901 mpz_setbit (result
->value
.integer
, i
);
3903 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3904 mpz_clrbit (result
->value
.integer
, i
);
3906 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3909 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3911 mpz_setbit (result
->value
.integer
, i
- ashift
);
3915 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3923 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3925 return simplify_shift (e
, s
, "ISHFT", false, 0);
3930 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3932 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3937 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3939 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3944 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3946 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3951 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3953 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3958 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3960 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3965 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3968 int shift
, ashift
, isize
, ssize
, delta
, k
;
3971 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3974 gfc_extract_int (s
, &shift
);
3976 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3977 isize
= gfc_integer_kinds
[k
].bit_size
;
3981 if (sz
->expr_type
!= EXPR_CONSTANT
)
3984 gfc_extract_int (sz
, &ssize
);
3997 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3998 "BIT_SIZE of first argument at %C");
4000 gfc_error ("Absolute value of SHIFT shall be less than or equal "
4002 return &gfc_bad_expr
;
4005 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4007 mpz_set (result
->value
.integer
, e
->value
.integer
);
4012 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
4014 bits
= XCNEWVEC (int, ssize
);
4016 for (i
= 0; i
< ssize
; i
++)
4017 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
4019 delta
= ssize
- ashift
;
4023 for (i
= 0; i
< delta
; i
++)
4026 mpz_clrbit (result
->value
.integer
, i
+ shift
);
4028 mpz_setbit (result
->value
.integer
, i
+ shift
);
4031 for (i
= delta
; i
< ssize
; i
++)
4034 mpz_clrbit (result
->value
.integer
, i
- delta
);
4036 mpz_setbit (result
->value
.integer
, i
- delta
);
4041 for (i
= 0; i
< ashift
; i
++)
4044 mpz_clrbit (result
->value
.integer
, i
+ delta
);
4046 mpz_setbit (result
->value
.integer
, i
+ delta
);
4049 for (i
= ashift
; i
< ssize
; i
++)
4052 mpz_clrbit (result
->value
.integer
, i
+ shift
);
4054 mpz_setbit (result
->value
.integer
, i
+ shift
);
4058 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
4066 gfc_simplify_kind (gfc_expr
*e
)
4068 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
4073 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
4074 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
4076 gfc_expr
*l
, *u
, *result
;
4079 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4080 gfc_default_integer_kind
);
4082 return &gfc_bad_expr
;
4084 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4086 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
4087 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
4088 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
4092 gfc_expr
* dim
= result
;
4093 mpz_set_si (dim
->value
.integer
, d
);
4095 result
= simplify_size (array
, dim
, k
);
4096 gfc_free_expr (dim
);
4101 mpz_set_si (result
->value
.integer
, 1);
4106 /* Otherwise, we have a variable expression. */
4107 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
4110 if (!gfc_resolve_array_spec (as
, 0))
4113 /* The last dimension of an assumed-size array is special. */
4114 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
4115 || (coarray
&& d
== as
->rank
+ as
->corank
4116 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
4118 if (as
->lower
[d
-1] && as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
4120 gfc_free_expr (result
);
4121 return gfc_copy_expr (as
->lower
[d
-1]);
4127 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4129 /* Then, we need to know the extent of the given dimension. */
4130 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
4132 gfc_expr
*declared_bound
;
4134 bool constant_lbound
, constant_ubound
;
4139 gcc_assert (l
!= NULL
);
4141 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
4142 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
4144 empty_bound
= upper
? 0 : 1;
4145 declared_bound
= upper
? u
: l
;
4147 if ((!upper
&& !constant_lbound
)
4148 || (upper
&& !constant_ubound
))
4153 /* For {L,U}BOUND, the value depends on whether the array
4154 is empty. We can nevertheless simplify if the declared bound
4155 has the same value as that of an empty array, in which case
4156 the result isn't dependent on the array emptyness. */
4157 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
4158 mpz_set_si (result
->value
.integer
, empty_bound
);
4159 else if (!constant_lbound
|| !constant_ubound
)
4160 /* Array emptyness can't be determined, we can't simplify. */
4162 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
4163 mpz_set_si (result
->value
.integer
, empty_bound
);
4165 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4168 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4174 int d2
= 0, cnt
= 0;
4175 for (int idx
= 0; idx
< ref
->u
.ar
.dimen
; ++idx
)
4177 if (ref
->u
.ar
.dimen_type
[idx
] == DIMEN_ELEMENT
)
4179 else if (cnt
< d
- 1)
4184 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d2
+ d
- 1, &result
->value
.integer
, NULL
))
4188 mpz_set_si (result
->value
.integer
, (long int) 1);
4192 return range_check (result
, upper
? "UBOUND" : "LBOUND");
4195 gfc_free_expr (result
);
4201 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4205 ar_type type
= AR_UNKNOWN
;
4208 if (array
->ts
.type
== BT_CLASS
)
4211 if (array
->expr_type
!= EXPR_VARIABLE
)
4218 /* Do not attempt to resolve if error has already been issued. */
4219 if (array
->symtree
->n
.sym
->error
)
4222 /* Follow any component references. */
4223 as
= array
->symtree
->n
.sym
->as
;
4224 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4229 type
= ref
->u
.ar
.type
;
4230 switch (ref
->u
.ar
.type
)
4237 /* We're done because 'as' has already been set in the
4238 previous iteration. */
4252 as
= ref
->u
.c
.component
->as
;
4265 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
4266 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
4269 /* 'array' shall not be an unallocated allocatable variable or a pointer that
4270 is not associated. */
4271 if (array
->expr_type
== EXPR_VARIABLE
4272 && (gfc_expr_attr (array
).allocatable
|| gfc_expr_attr (array
).pointer
))
4276 || (as
->type
!= AS_DEFERRED
4277 && array
->expr_type
== EXPR_VARIABLE
4278 && !gfc_expr_attr (array
).allocatable
4279 && !gfc_expr_attr (array
).pointer
));
4283 /* Multi-dimensional bounds. */
4284 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4288 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4289 if (upper
&& type
== AR_FULL
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
4291 /* An error message will be emitted in
4292 check_assumed_size_reference (resolve.c). */
4293 return &gfc_bad_expr
;
4296 /* Simplify the bounds for each dimension. */
4297 for (d
= 0; d
< array
->rank
; d
++)
4299 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
4301 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4305 for (j
= 0; j
< d
; j
++)
4306 gfc_free_expr (bounds
[j
]);
4309 return &gfc_bad_expr
;
4315 /* Allocate the result expression. */
4316 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4317 gfc_default_integer_kind
);
4319 return &gfc_bad_expr
;
4321 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
4323 /* The result is a rank 1 array; its size is the rank of the first
4324 argument to {L,U}BOUND. */
4326 e
->shape
= gfc_get_shape (1);
4327 mpz_init_set_ui (e
->shape
[0], array
->rank
);
4329 /* Create the constructor for this array. */
4330 for (d
= 0; d
< array
->rank
; d
++)
4331 gfc_constructor_append_expr (&e
->value
.constructor
,
4332 bounds
[d
], &e
->where
);
4338 /* A DIM argument is specified. */
4339 if (dim
->expr_type
!= EXPR_CONSTANT
)
4342 d
= mpz_get_si (dim
->value
.integer
);
4344 if ((d
< 1 || d
> array
->rank
)
4345 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
4347 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4348 return &gfc_bad_expr
;
4351 if (as
&& as
->type
== AS_ASSUMED_RANK
)
4354 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
4360 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4366 if (array
->expr_type
!= EXPR_VARIABLE
)
4369 /* Follow any component references. */
4370 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
4371 ? array
->ts
.u
.derived
->components
->as
4372 : array
->symtree
->n
.sym
->as
;
4373 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4378 switch (ref
->u
.ar
.type
)
4381 if (ref
->u
.ar
.as
->corank
> 0)
4383 gcc_assert (as
== ref
->u
.ar
.as
);
4390 /* We're done because 'as' has already been set in the
4391 previous iteration. */
4405 as
= ref
->u
.c
.component
->as
;
4419 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
4424 /* Multi-dimensional cobounds. */
4425 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4429 /* Simplify the cobounds for each dimension. */
4430 for (d
= 0; d
< as
->corank
; d
++)
4432 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
4433 upper
, as
, ref
, true);
4434 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4438 for (j
= 0; j
< d
; j
++)
4439 gfc_free_expr (bounds
[j
]);
4444 /* Allocate the result expression. */
4445 e
= gfc_get_expr ();
4446 e
->where
= array
->where
;
4447 e
->expr_type
= EXPR_ARRAY
;
4448 e
->ts
.type
= BT_INTEGER
;
4449 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
4450 gfc_default_integer_kind
);
4454 return &gfc_bad_expr
;
4458 /* The result is a rank 1 array; its size is the rank of the first
4459 argument to {L,U}COBOUND. */
4461 e
->shape
= gfc_get_shape (1);
4462 mpz_init_set_ui (e
->shape
[0], as
->corank
);
4464 /* Create the constructor for this array. */
4465 for (d
= 0; d
< as
->corank
; d
++)
4466 gfc_constructor_append_expr (&e
->value
.constructor
,
4467 bounds
[d
], &e
->where
);
4472 /* A DIM argument is specified. */
4473 if (dim
->expr_type
!= EXPR_CONSTANT
)
4476 d
= mpz_get_si (dim
->value
.integer
);
4478 if (d
< 1 || d
> as
->corank
)
4480 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4481 return &gfc_bad_expr
;
4484 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
4490 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4492 return simplify_bound (array
, dim
, kind
, 0);
4497 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4499 return simplify_cobound (array
, dim
, kind
, 0);
4503 gfc_simplify_leadz (gfc_expr
*e
)
4505 unsigned long lz
, bs
;
4508 if (e
->expr_type
!= EXPR_CONSTANT
)
4511 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4512 bs
= gfc_integer_kinds
[i
].bit_size
;
4513 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
4515 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
4518 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
4520 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
4524 /* Check for constant length of a substring. */
4527 substring_has_constant_len (gfc_expr
*e
)
4530 HOST_WIDE_INT istart
, iend
, length
;
4531 bool equal_length
= false;
4533 if (e
->ts
.type
!= BT_CHARACTER
)
4536 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4537 if (ref
->type
!= REF_COMPONENT
&& ref
->type
!= REF_ARRAY
)
4541 || ref
->type
!= REF_SUBSTRING
4543 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
4545 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
4548 /* Basic checks on substring starting and ending indices. */
4549 if (!gfc_resolve_substring (ref
, &equal_length
))
4552 istart
= gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
);
4553 iend
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
);
4556 length
= iend
- istart
+ 1;
4560 /* Fix substring length. */
4561 e
->value
.character
.length
= length
;
4568 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
4571 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
4574 return &gfc_bad_expr
;
4576 if (e
->expr_type
== EXPR_CONSTANT
4577 || substring_has_constant_len (e
))
4579 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4580 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
4581 return range_check (result
, "LEN");
4583 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
4584 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
4585 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
4587 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4588 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
4589 return range_check (result
, "LEN");
4591 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
4592 && e
->symtree
->n
.sym
4593 && e
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
4594 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
4595 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
4596 && e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
4597 && UNLIMITED_POLY (e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
))
4599 /* The expression in assoc->target points to a ref to the _data component
4600 of the unlimited polymorphic entity. To get the _len component the last
4601 _data ref needs to be stripped and a ref to the _len component added. */
4602 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
, k
);
4609 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
4612 size_t count
, len
, i
;
4613 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
4616 return &gfc_bad_expr
;
4618 if (e
->expr_type
!= EXPR_CONSTANT
)
4621 len
= e
->value
.character
.length
;
4622 for (count
= 0, i
= 1; i
<= len
; i
++)
4623 if (e
->value
.character
.string
[len
- i
] == ' ')
4628 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
4629 return range_check (result
, "LEN_TRIM");
4633 gfc_simplify_lgamma (gfc_expr
*x
)
4638 if (x
->expr_type
!= EXPR_CONSTANT
)
4641 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4642 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
4644 return range_check (result
, "LGAMMA");
4649 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
4651 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4654 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4655 gfc_compare_string (a
, b
) >= 0);
4660 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
4662 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4665 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4666 gfc_compare_string (a
, b
) > 0);
4671 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
4673 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4676 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4677 gfc_compare_string (a
, b
) <= 0);
4682 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
4684 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4687 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4688 gfc_compare_string (a
, b
) < 0);
4693 gfc_simplify_log (gfc_expr
*x
)
4697 if (x
->expr_type
!= EXPR_CONSTANT
)
4700 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4705 if (mpfr_sgn (x
->value
.real
) <= 0)
4707 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4708 "to zero", &x
->where
);
4709 gfc_free_expr (result
);
4710 return &gfc_bad_expr
;
4713 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4717 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
4718 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
4720 gfc_error ("Complex argument of LOG at %L cannot be zero",
4722 gfc_free_expr (result
);
4723 return &gfc_bad_expr
;
4726 gfc_set_model_kind (x
->ts
.kind
);
4727 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
4731 gfc_internal_error ("gfc_simplify_log: bad type");
4734 return range_check (result
, "LOG");
4739 gfc_simplify_log10 (gfc_expr
*x
)
4743 if (x
->expr_type
!= EXPR_CONSTANT
)
4746 if (mpfr_sgn (x
->value
.real
) <= 0)
4748 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4749 "to zero", &x
->where
);
4750 return &gfc_bad_expr
;
4753 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4754 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4756 return range_check (result
, "LOG10");
4761 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
4765 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
4767 return &gfc_bad_expr
;
4769 if (e
->expr_type
!= EXPR_CONSTANT
)
4772 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
4777 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
4780 int row
, result_rows
, col
, result_columns
;
4781 int stride_a
, offset_a
, stride_b
, offset_b
;
4783 if (!is_constant_array_expr (matrix_a
)
4784 || !is_constant_array_expr (matrix_b
))
4787 /* MATMUL should do mixed-mode arithmetic. Set the result type. */
4788 if (matrix_a
->ts
.type
!= matrix_b
->ts
.type
)
4791 e
.expr_type
= EXPR_OP
;
4792 gfc_clear_ts (&e
.ts
);
4793 e
.value
.op
.op
= INTRINSIC_NONE
;
4794 e
.value
.op
.op1
= matrix_a
;
4795 e
.value
.op
.op2
= matrix_b
;
4796 gfc_type_convert_binary (&e
, 1);
4797 result
= gfc_get_array_expr (e
.ts
.type
, e
.ts
.kind
, &matrix_a
->where
);
4801 result
= gfc_get_array_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
4805 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
4808 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4810 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4813 result
->shape
= gfc_get_shape (result
->rank
);
4814 mpz_init_set_si (result
->shape
[0], result_columns
);
4816 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
4818 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4820 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4824 result
->shape
= gfc_get_shape (result
->rank
);
4825 mpz_init_set_si (result
->shape
[0], result_rows
);
4827 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
4829 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4830 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4831 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4832 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4835 result
->shape
= gfc_get_shape (result
->rank
);
4836 mpz_init_set_si (result
->shape
[0], result_rows
);
4837 mpz_init_set_si (result
->shape
[1], result_columns
);
4843 for (col
= 0; col
< result_columns
; ++col
)
4847 for (row
= 0; row
< result_rows
; ++row
)
4849 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
4850 matrix_b
, 1, offset_b
, false);
4851 gfc_constructor_append_expr (&result
->value
.constructor
,
4857 offset_b
+= stride_b
;
4865 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
4870 if (i
->expr_type
!= EXPR_CONSTANT
)
4873 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
4875 return &gfc_bad_expr
;
4876 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4878 bool fail
= gfc_extract_int (i
, &arg
);
4881 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4883 /* MASKR(n) = 2^n - 1 */
4884 mpz_set_ui (result
->value
.integer
, 1);
4885 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4886 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4888 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4895 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4901 if (i
->expr_type
!= EXPR_CONSTANT
)
4904 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4906 return &gfc_bad_expr
;
4907 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4909 bool fail
= gfc_extract_int (i
, &arg
);
4912 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4914 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4915 mpz_init_set_ui (z
, 1);
4916 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4917 mpz_set_ui (result
->value
.integer
, 1);
4918 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4919 gfc_integer_kinds
[k
].bit_size
- arg
);
4920 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4923 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4930 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4933 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4935 if (mask
->expr_type
== EXPR_CONSTANT
)
4937 result
= gfc_copy_expr (mask
->value
.logical
? tsource
: fsource
);
4938 /* Parenthesis is needed to get lower bounds of 1. */
4939 result
= gfc_get_parentheses (result
);
4940 gfc_simplify_expr (result
, 1);
4944 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4945 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4948 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4950 if (tsource
->ts
.type
== BT_DERIVED
)
4951 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4952 else if (tsource
->ts
.type
== BT_CHARACTER
)
4953 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4955 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4956 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4957 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4961 if (mask_ctor
->expr
->value
.logical
)
4962 gfc_constructor_append_expr (&result
->value
.constructor
,
4963 gfc_copy_expr (tsource_ctor
->expr
),
4966 gfc_constructor_append_expr (&result
->value
.constructor
,
4967 gfc_copy_expr (fsource_ctor
->expr
),
4969 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4970 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4971 mask_ctor
= gfc_constructor_next (mask_ctor
);
4974 result
->shape
= gfc_get_shape (1);
4975 gfc_array_size (result
, &result
->shape
[0]);
4982 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4984 mpz_t arg1
, arg2
, mask
;
4987 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4988 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4991 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4993 /* Convert all argument to unsigned. */
4994 mpz_init_set (arg1
, i
->value
.integer
);
4995 mpz_init_set (arg2
, j
->value
.integer
);
4996 mpz_init_set (mask
, mask_expr
->value
.integer
);
4998 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4999 mpz_and (arg1
, arg1
, mask
);
5000 mpz_com (mask
, mask
);
5001 mpz_and (arg2
, arg2
, mask
);
5002 mpz_ior (result
->value
.integer
, arg1
, arg2
);
5012 /* Selects between current value and extremum for simplify_min_max
5013 and simplify_minval_maxval. */
5015 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
, bool back_val
)
5019 switch (arg
->ts
.type
)
5022 if (extremum
->ts
.kind
< arg
->ts
.kind
)
5023 extremum
->ts
.kind
= arg
->ts
.kind
;
5024 ret
= mpz_cmp (arg
->value
.integer
,
5025 extremum
->value
.integer
) * sign
;
5027 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
5031 if (extremum
->ts
.kind
< arg
->ts
.kind
)
5032 extremum
->ts
.kind
= arg
->ts
.kind
;
5033 if (mpfr_nan_p (extremum
->value
.real
))
5036 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
5038 else if (mpfr_nan_p (arg
->value
.real
))
5042 ret
= mpfr_cmp (arg
->value
.real
, extremum
->value
.real
) * sign
;
5044 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
5049 #define LENGTH(x) ((x)->value.character.length)
5050 #define STRING(x) ((x)->value.character.string)
5051 if (LENGTH (extremum
) < LENGTH(arg
))
5053 gfc_char_t
*tmp
= STRING(extremum
);
5055 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
5056 memcpy (STRING(extremum
), tmp
,
5057 LENGTH(extremum
) * sizeof (gfc_char_t
));
5058 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
5059 LENGTH(arg
) - LENGTH(extremum
));
5060 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
5061 LENGTH(extremum
) = LENGTH(arg
);
5064 ret
= gfc_compare_string (arg
, extremum
) * sign
;
5067 free (STRING(extremum
));
5068 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
5069 memcpy (STRING(extremum
), STRING(arg
),
5070 LENGTH(arg
) * sizeof (gfc_char_t
));
5071 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
5072 LENGTH(extremum
) - LENGTH(arg
));
5073 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
5080 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5082 if (back_val
&& ret
== 0)
5089 /* This function is special since MAX() can take any number of
5090 arguments. The simplified expression is a rewritten version of the
5091 argument list containing at most one constant element. Other
5092 constant elements are deleted. Because the argument list has
5093 already been checked, this function always succeeds. sign is 1 for
5094 MAX(), -1 for MIN(). */
5097 simplify_min_max (gfc_expr
*expr
, int sign
)
5100 gfc_actual_arglist
*arg
, *last
, *extremum
;
5101 gfc_expr
*tmp
, *ret
;
5107 arg
= expr
->value
.function
.actual
;
5109 for (; arg
; last
= arg
, arg
= arg
->next
)
5111 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
5114 if (extremum
== NULL
)
5120 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
5122 /* Delete the extra constant argument. */
5123 last
->next
= arg
->next
;
5126 gfc_free_actual_arglist (arg
);
5130 /* If there is one value left, replace the function call with the
5132 if (expr
->value
.function
.actual
->next
!= NULL
)
5135 /* Handle special cases of specific functions (min|max)1 and
5138 tmp
= expr
->value
.function
.actual
->expr
;
5139 fname
= expr
->value
.function
.isym
->name
;
5141 if ((tmp
->ts
.type
!= BT_INTEGER
|| tmp
->ts
.kind
!= gfc_integer_4_kind
)
5142 && (strcmp (fname
, "min1") == 0 || strcmp (fname
, "max1") == 0))
5144 /* Explicit conversion, turn off -Wconversion and -Wconversion-extra
5146 tmp1
= warn_conversion
;
5147 tmp2
= warn_conversion_extra
;
5148 warn_conversion
= warn_conversion_extra
= 0;
5150 ret
= gfc_convert_constant (tmp
, BT_INTEGER
, gfc_integer_4_kind
);
5152 warn_conversion
= tmp1
;
5153 warn_conversion_extra
= tmp2
;
5155 else if ((tmp
->ts
.type
!= BT_REAL
|| tmp
->ts
.kind
!= gfc_real_4_kind
)
5156 && (strcmp (fname
, "amin0") == 0 || strcmp (fname
, "amax0") == 0))
5158 ret
= gfc_convert_constant (tmp
, BT_REAL
, gfc_real_4_kind
);
5161 ret
= gfc_copy_expr (tmp
);
5169 gfc_simplify_min (gfc_expr
*e
)
5171 return simplify_min_max (e
, -1);
5176 gfc_simplify_max (gfc_expr
*e
)
5178 return simplify_min_max (e
, 1);
5181 /* Helper function for gfc_simplify_minval. */
5184 gfc_min (gfc_expr
*op1
, gfc_expr
*op2
)
5186 min_max_choose (op1
, op2
, -1);
5187 gfc_free_expr (op1
);
5191 /* Simplify minval for constant arrays. */
5194 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5196 return simplify_transformation (array
, dim
, mask
, INT_MAX
, gfc_min
);
5199 /* Helper function for gfc_simplify_maxval. */
5202 gfc_max (gfc_expr
*op1
, gfc_expr
*op2
)
5204 min_max_choose (op1
, op2
, 1);
5205 gfc_free_expr (op1
);
5210 /* Simplify maxval for constant arrays. */
5213 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5215 return simplify_transformation (array
, dim
, mask
, INT_MIN
, gfc_max
);
5219 /* Transform minloc or maxloc of an array, according to MASK,
5220 to the scalar result. This code is mostly identical to
5221 simplify_transformation_to_scalar. */
5224 simplify_minmaxloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
5225 gfc_expr
*extremum
, int sign
, bool back_val
)
5228 gfc_constructor
*array_ctor
, *mask_ctor
;
5231 mpz_set_si (result
->value
.integer
, 0);
5234 /* Shortcut for constant .FALSE. MASK. */
5236 && mask
->expr_type
== EXPR_CONSTANT
5237 && !mask
->value
.logical
)
5240 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5241 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5242 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5246 mpz_init_set_si (count
, 0);
5249 mpz_add_ui (count
, count
, 1);
5250 a
= array_ctor
->expr
;
5251 array_ctor
= gfc_constructor_next (array_ctor
);
5252 /* A constant MASK equals .TRUE. here and can be ignored. */
5255 m
= mask_ctor
->expr
;
5256 mask_ctor
= gfc_constructor_next (mask_ctor
);
5257 if (!m
->value
.logical
)
5260 if (min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5261 mpz_set (result
->value
.integer
, count
);
5264 gfc_free_expr (extremum
);
5268 /* Simplify minloc / maxloc in the absence of a dim argument. */
5271 simplify_minmaxloc_nodim (gfc_expr
*result
, gfc_expr
*extremum
,
5272 gfc_expr
*array
, gfc_expr
*mask
, int sign
,
5275 ssize_t res
[GFC_MAX_DIMENSIONS
];
5277 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5278 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5279 sstride
[GFC_MAX_DIMENSIONS
];
5284 for (i
= 0; i
<array
->rank
; i
++)
5287 /* Shortcut for constant .FALSE. MASK. */
5289 && mask
->expr_type
== EXPR_CONSTANT
5290 && !mask
->value
.logical
)
5293 if (array
->shape
== NULL
)
5296 for (i
= 0; i
< array
->rank
; i
++)
5299 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5300 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5305 continue_loop
= true;
5306 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5307 if (mask
&& mask
->rank
> 0)
5308 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5312 /* Loop over the array elements (and mask), keeping track of
5313 the indices to return. */
5314 while (continue_loop
)
5318 a
= array_ctor
->expr
;
5321 m
= mask_ctor
->expr
;
5322 ma
= m
->value
.logical
;
5323 mask_ctor
= gfc_constructor_next (mask_ctor
);
5328 if (ma
&& min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5330 for (i
= 0; i
<array
->rank
; i
++)
5333 array_ctor
= gfc_constructor_next (array_ctor
);
5335 } while (count
[0] != extent
[0]);
5339 /* When we get to the end of a dimension, reset it and increment
5340 the next dimension. */
5343 if (n
>= array
->rank
)
5345 continue_loop
= false;
5350 } while (count
[n
] == extent
[n
]);
5354 gfc_free_expr (extremum
);
5355 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5356 for (i
= 0; i
<array
->rank
; i
++)
5359 r_expr
= result_ctor
->expr
;
5360 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5361 result_ctor
= gfc_constructor_next (result_ctor
);
5366 /* Helper function for gfc_simplify_minmaxloc - build an array
5367 expression with n elements. */
5370 new_array (bt type
, int kind
, int n
, locus
*where
)
5375 result
= gfc_get_array_expr (type
, kind
, where
);
5377 result
->shape
= gfc_get_shape(1);
5378 mpz_init_set_si (result
->shape
[0], n
);
5379 for (i
= 0; i
< n
; i
++)
5381 gfc_constructor_append_expr (&result
->value
.constructor
,
5382 gfc_get_constant_expr (type
, kind
, where
),
5389 /* Simplify minloc and maxloc. This code is mostly identical to
5390 simplify_transformation_to_array. */
5393 simplify_minmaxloc_to_array (gfc_expr
*result
, gfc_expr
*array
,
5394 gfc_expr
*dim
, gfc_expr
*mask
,
5395 gfc_expr
*extremum
, int sign
, bool back_val
)
5398 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5399 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5400 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5402 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5403 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5404 tmpstride
[GFC_MAX_DIMENSIONS
];
5406 /* Shortcut for constant .FALSE. MASK. */
5408 && mask
->expr_type
== EXPR_CONSTANT
5409 && !mask
->value
.logical
)
5412 /* Build an indexed table for array element expressions to minimize
5413 linked-list traversal. Masked elements are set to NULL. */
5414 gfc_array_size (array
, &size
);
5415 arraysize
= mpz_get_ui (size
);
5418 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5420 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5422 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5423 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5425 for (i
= 0; i
< arraysize
; ++i
)
5427 arrayvec
[i
] = array_ctor
->expr
;
5428 array_ctor
= gfc_constructor_next (array_ctor
);
5432 if (!mask_ctor
->expr
->value
.logical
)
5435 mask_ctor
= gfc_constructor_next (mask_ctor
);
5439 /* Same for the result expression. */
5440 gfc_array_size (result
, &size
);
5441 resultsize
= mpz_get_ui (size
);
5444 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5445 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5446 for (i
= 0; i
< resultsize
; ++i
)
5448 resultvec
[i
] = result_ctor
->expr
;
5449 result_ctor
= gfc_constructor_next (result_ctor
);
5452 gfc_extract_int (dim
, &dim_index
);
5453 dim_index
-= 1; /* zero-base index */
5457 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5460 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5463 dim_extent
= mpz_get_si (array
->shape
[i
]);
5464 dim_stride
= tmpstride
[i
];
5468 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5469 sstride
[n
] = tmpstride
[i
];
5470 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5474 done
= resultsize
<= 0;
5480 ex
= gfc_copy_expr (extremum
);
5481 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5483 if (*src
&& min_max_choose (*src
, ex
, sign
, back_val
) > 0)
5484 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5493 while (!done
&& count
[n
] == extent
[n
])
5496 base
-= sstride
[n
] * extent
[n
];
5497 dest
-= dstride
[n
] * extent
[n
];
5500 if (n
< result
->rank
)
5502 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5503 times, we'd warn for the last iteration, because the
5504 array index will have already been incremented to the
5505 array sizes, and we can't tell that this must make
5506 the test against result->rank false, because ranks
5507 must not exceed GFC_MAX_DIMENSIONS. */
5508 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5519 /* Place updated expression in result constructor. */
5520 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5521 for (i
= 0; i
< resultsize
; ++i
)
5523 result_ctor
->expr
= resultvec
[i
];
5524 result_ctor
= gfc_constructor_next (result_ctor
);
5533 /* Simplify minloc and maxloc for constant arrays. */
5536 gfc_simplify_minmaxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
5537 gfc_expr
*kind
, gfc_expr
*back
, int sign
)
5543 bool back_val
= false;
5545 if (!is_constant_array_expr (array
)
5546 || !gfc_is_constant_expr (dim
))
5550 && !is_constant_array_expr (mask
)
5551 && mask
->expr_type
!= EXPR_CONSTANT
)
5556 if (gfc_extract_int (kind
, &ikind
, -1))
5560 ikind
= gfc_default_integer_kind
;
5564 if (back
->expr_type
!= EXPR_CONSTANT
)
5567 back_val
= back
->value
.logical
;
5577 extremum
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
5578 init_result_expr (extremum
, init_val
, array
);
5582 result
= transformational_result (array
, dim
, BT_INTEGER
,
5583 ikind
, &array
->where
);
5584 init_result_expr (result
, 0, array
);
5586 if (array
->rank
== 1)
5587 return simplify_minmaxloc_to_scalar (result
, array
, mask
, extremum
,
5590 return simplify_minmaxloc_to_array (result
, array
, dim
, mask
, extremum
,
5595 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5596 return simplify_minmaxloc_nodim (result
, extremum
, array
, mask
,
5602 gfc_simplify_minloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5605 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, -1);
5609 gfc_simplify_maxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5612 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, 1);
5615 /* Simplify findloc to scalar. Similar to
5616 simplify_minmaxloc_to_scalar. */
5619 simplify_findloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5620 gfc_expr
*mask
, int back_val
)
5623 gfc_constructor
*array_ctor
, *mask_ctor
;
5626 mpz_set_si (result
->value
.integer
, 0);
5628 /* Shortcut for constant .FALSE. MASK. */
5630 && mask
->expr_type
== EXPR_CONSTANT
5631 && !mask
->value
.logical
)
5634 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5635 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5636 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5640 mpz_init_set_si (count
, 0);
5643 mpz_add_ui (count
, count
, 1);
5644 a
= array_ctor
->expr
;
5645 array_ctor
= gfc_constructor_next (array_ctor
);
5646 /* A constant MASK equals .TRUE. here and can be ignored. */
5649 m
= mask_ctor
->expr
;
5650 mask_ctor
= gfc_constructor_next (mask_ctor
);
5651 if (!m
->value
.logical
)
5654 if (gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5656 /* We have a match. If BACK is true, continue so we find
5658 mpz_set (result
->value
.integer
, count
);
5667 /* Simplify findloc in the absence of a dim argument. Similar to
5668 simplify_minmaxloc_nodim. */
5671 simplify_findloc_nodim (gfc_expr
*result
, gfc_expr
*value
, gfc_expr
*array
,
5672 gfc_expr
*mask
, bool back_val
)
5674 ssize_t res
[GFC_MAX_DIMENSIONS
];
5676 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5677 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5678 sstride
[GFC_MAX_DIMENSIONS
];
5683 for (i
= 0; i
< array
->rank
; i
++)
5686 /* Shortcut for constant .FALSE. MASK. */
5688 && mask
->expr_type
== EXPR_CONSTANT
5689 && !mask
->value
.logical
)
5692 for (i
= 0; i
< array
->rank
; i
++)
5695 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5696 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5701 continue_loop
= true;
5702 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5703 if (mask
&& mask
->rank
> 0)
5704 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5708 /* Loop over the array elements (and mask), keeping track of
5709 the indices to return. */
5710 while (continue_loop
)
5714 a
= array_ctor
->expr
;
5717 m
= mask_ctor
->expr
;
5718 ma
= m
->value
.logical
;
5719 mask_ctor
= gfc_constructor_next (mask_ctor
);
5724 if (ma
&& gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5726 for (i
= 0; i
< array
->rank
; i
++)
5731 array_ctor
= gfc_constructor_next (array_ctor
);
5733 } while (count
[0] != extent
[0]);
5737 /* When we get to the end of a dimension, reset it and increment
5738 the next dimension. */
5741 if (n
>= array
->rank
)
5743 continue_loop
= false;
5748 } while (count
[n
] == extent
[n
]);
5752 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5753 for (i
= 0; i
< array
->rank
; i
++)
5756 r_expr
= result_ctor
->expr
;
5757 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5758 result_ctor
= gfc_constructor_next (result_ctor
);
5764 /* Simplify findloc to an array. Similar to
5765 simplify_minmaxloc_to_array. */
5768 simplify_findloc_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5769 gfc_expr
*dim
, gfc_expr
*mask
, bool back_val
)
5772 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5773 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5774 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5776 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5777 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5778 tmpstride
[GFC_MAX_DIMENSIONS
];
5780 /* Shortcut for constant .FALSE. MASK. */
5782 && mask
->expr_type
== EXPR_CONSTANT
5783 && !mask
->value
.logical
)
5786 /* Build an indexed table for array element expressions to minimize
5787 linked-list traversal. Masked elements are set to NULL. */
5788 gfc_array_size (array
, &size
);
5789 arraysize
= mpz_get_ui (size
);
5792 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5794 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5796 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5797 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5799 for (i
= 0; i
< arraysize
; ++i
)
5801 arrayvec
[i
] = array_ctor
->expr
;
5802 array_ctor
= gfc_constructor_next (array_ctor
);
5806 if (!mask_ctor
->expr
->value
.logical
)
5809 mask_ctor
= gfc_constructor_next (mask_ctor
);
5813 /* Same for the result expression. */
5814 gfc_array_size (result
, &size
);
5815 resultsize
= mpz_get_ui (size
);
5818 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5819 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5820 for (i
= 0; i
< resultsize
; ++i
)
5822 resultvec
[i
] = result_ctor
->expr
;
5823 result_ctor
= gfc_constructor_next (result_ctor
);
5826 gfc_extract_int (dim
, &dim_index
);
5828 dim_index
-= 1; /* Zero-base index. */
5832 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5835 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5838 dim_extent
= mpz_get_si (array
->shape
[i
]);
5839 dim_stride
= tmpstride
[i
];
5843 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5844 sstride
[n
] = tmpstride
[i
];
5845 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5849 done
= resultsize
<= 0;
5854 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5856 if (*src
&& gfc_compare_expr (*src
, value
, INTRINSIC_EQ
) == 0)
5858 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5869 while (!done
&& count
[n
] == extent
[n
])
5872 base
-= sstride
[n
] * extent
[n
];
5873 dest
-= dstride
[n
] * extent
[n
];
5876 if (n
< result
->rank
)
5878 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5879 times, we'd warn for the last iteration, because the
5880 array index will have already been incremented to the
5881 array sizes, and we can't tell that this must make
5882 the test against result->rank false, because ranks
5883 must not exceed GFC_MAX_DIMENSIONS. */
5884 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5895 /* Place updated expression in result constructor. */
5896 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5897 for (i
= 0; i
< resultsize
; ++i
)
5899 result_ctor
->expr
= resultvec
[i
];
5900 result_ctor
= gfc_constructor_next (result_ctor
);
5908 /* Simplify findloc. */
5911 gfc_simplify_findloc (gfc_expr
*array
, gfc_expr
*value
, gfc_expr
*dim
,
5912 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
5916 bool back_val
= false;
5918 if (!is_constant_array_expr (array
)
5919 || !gfc_is_constant_expr (dim
))
5922 if (! gfc_is_constant_expr (value
))
5926 && !is_constant_array_expr (mask
)
5927 && mask
->expr_type
!= EXPR_CONSTANT
)
5932 if (gfc_extract_int (kind
, &ikind
, -1))
5936 ikind
= gfc_default_integer_kind
;
5940 if (back
->expr_type
!= EXPR_CONSTANT
)
5943 back_val
= back
->value
.logical
;
5948 result
= transformational_result (array
, dim
, BT_INTEGER
,
5949 ikind
, &array
->where
);
5950 init_result_expr (result
, 0, array
);
5952 if (array
->rank
== 1)
5953 return simplify_findloc_to_scalar (result
, array
, value
, mask
,
5956 return simplify_findloc_to_array (result
, array
, value
, dim
, mask
,
5961 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5962 return simplify_findloc_nodim (result
, value
, array
, mask
, back_val
);
5968 gfc_simplify_maxexponent (gfc_expr
*x
)
5970 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5971 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5972 gfc_real_kinds
[i
].max_exponent
);
5977 gfc_simplify_minexponent (gfc_expr
*x
)
5979 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5980 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5981 gfc_real_kinds
[i
].min_exponent
);
5986 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
5991 /* First check p. */
5992 if (p
->expr_type
!= EXPR_CONSTANT
)
5995 /* p shall not be 0. */
5999 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
6001 gfc_error ("Argument %qs of MOD at %L shall not be zero",
6003 return &gfc_bad_expr
;
6007 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
6009 gfc_error ("Argument %qs of MOD at %L shall not be zero",
6011 return &gfc_bad_expr
;
6015 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6018 if (a
->expr_type
!= EXPR_CONSTANT
)
6021 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6022 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6024 if (a
->ts
.type
== BT_INTEGER
)
6025 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6028 gfc_set_model_kind (kind
);
6029 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6033 return range_check (result
, "MOD");
6038 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
6043 /* First check p. */
6044 if (p
->expr_type
!= EXPR_CONSTANT
)
6047 /* p shall not be 0. */
6051 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
6053 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6055 return &gfc_bad_expr
;
6059 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
6061 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6063 return &gfc_bad_expr
;
6067 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6070 if (a
->expr_type
!= EXPR_CONSTANT
)
6073 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6074 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6076 if (a
->ts
.type
== BT_INTEGER
)
6077 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6080 gfc_set_model_kind (kind
);
6081 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6083 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
6085 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
6086 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
6090 mpfr_copysign (result
->value
.real
, result
->value
.real
,
6091 p
->value
.real
, GFC_RND_MODE
);
6094 return range_check (result
, "MODULO");
6099 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
6102 mpfr_exp_t emin
, emax
;
6105 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
6108 result
= gfc_copy_expr (x
);
6110 /* Save current values of emin and emax. */
6111 emin
= mpfr_get_emin ();
6112 emax
= mpfr_get_emax ();
6114 /* Set emin and emax for the current model number. */
6115 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
6116 mpfr_set_emin ((mpfr_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
6117 mpfr_get_prec(result
->value
.real
) + 1);
6118 mpfr_set_emax ((mpfr_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
6119 mpfr_check_range (result
->value
.real
, 0, MPFR_RNDU
);
6121 if (mpfr_sgn (s
->value
.real
) > 0)
6123 mpfr_nextabove (result
->value
.real
);
6124 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDU
);
6128 mpfr_nextbelow (result
->value
.real
);
6129 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDD
);
6132 mpfr_set_emin (emin
);
6133 mpfr_set_emax (emax
);
6135 /* Only NaN can occur. Do not use range check as it gives an
6136 error for denormal numbers. */
6137 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
6139 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
6140 gfc_free_expr (result
);
6141 return &gfc_bad_expr
;
6149 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
6151 gfc_expr
*itrunc
, *result
;
6154 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
6156 return &gfc_bad_expr
;
6158 if (e
->expr_type
!= EXPR_CONSTANT
)
6161 itrunc
= gfc_copy_expr (e
);
6162 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
6164 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
6165 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
6167 gfc_free_expr (itrunc
);
6169 return range_check (result
, name
);
6174 gfc_simplify_new_line (gfc_expr
*e
)
6178 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
6179 result
->value
.character
.string
[0] = '\n';
6186 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
6188 return simplify_nint ("NINT", e
, k
);
6193 gfc_simplify_idnint (gfc_expr
*e
)
6195 return simplify_nint ("IDNINT", e
, NULL
);
6198 static int norm2_scale
;
6201 norm2_add_squared (gfc_expr
*result
, gfc_expr
*e
)
6205 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6206 gcc_assert (result
->ts
.type
== BT_REAL
6207 && result
->expr_type
== EXPR_CONSTANT
);
6209 gfc_set_model_kind (result
->ts
.kind
);
6210 int index
= gfc_validate_kind (BT_REAL
, result
->ts
.kind
, false);
6212 if (mpfr_regular_p (result
->value
.real
))
6214 exp
= mpfr_get_exp (result
->value
.real
);
6215 /* If result is getting close to overflowing, scale down. */
6216 if (exp
>= gfc_real_kinds
[index
].max_exponent
- 4
6217 && norm2_scale
<= gfc_real_kinds
[index
].max_exponent
- 2)
6220 mpfr_div_ui (result
->value
.real
, result
->value
.real
, 16,
6226 if (mpfr_regular_p (e
->value
.real
))
6228 exp
= mpfr_get_exp (e
->value
.real
);
6229 /* If e**2 would overflow or close to overflowing, scale down. */
6230 if (exp
- norm2_scale
>= gfc_real_kinds
[index
].max_exponent
/ 2 - 2)
6232 int new_scale
= gfc_real_kinds
[index
].max_exponent
/ 2 + 4;
6233 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6234 mpfr_set_exp (tmp
, new_scale
- norm2_scale
);
6235 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6236 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6237 norm2_scale
= new_scale
;
6242 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6243 mpfr_set_exp (tmp
, norm2_scale
);
6244 mpfr_div (tmp
, e
->value
.real
, tmp
, GFC_RND_MODE
);
6247 mpfr_set (tmp
, e
->value
.real
, GFC_RND_MODE
);
6248 mpfr_pow_ui (tmp
, tmp
, 2, GFC_RND_MODE
);
6249 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
6258 norm2_do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
6260 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6261 gcc_assert (result
->ts
.type
== BT_REAL
6262 && result
->expr_type
== EXPR_CONSTANT
);
6265 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6266 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6267 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6271 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6272 mpfr_set_exp (tmp
, norm2_scale
);
6273 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6283 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
6288 size_zero
= gfc_is_size_zero_array (e
);
6290 if (!(is_constant_array_expr (e
) || size_zero
)
6291 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
6294 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6295 init_result_expr (result
, 0, NULL
);
6301 if (!dim
|| e
->rank
== 1)
6303 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
6305 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6306 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6310 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6311 mpfr_set_exp (tmp
, norm2_scale
);
6312 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6318 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
6327 gfc_simplify_not (gfc_expr
*e
)
6331 if (e
->expr_type
!= EXPR_CONSTANT
)
6334 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6335 mpz_com (result
->value
.integer
, e
->value
.integer
);
6337 return range_check (result
, "NOT");
6342 gfc_simplify_null (gfc_expr
*mold
)
6348 result
= gfc_copy_expr (mold
);
6349 result
->expr_type
= EXPR_NULL
;
6352 result
= gfc_get_null_expr (NULL
);
6359 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
6363 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6365 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6366 return &gfc_bad_expr
;
6369 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6372 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
6375 /* FIXME: gfc_current_locus is wrong. */
6376 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6377 &gfc_current_locus
);
6379 if (failed
&& failed
->value
.logical
!= 0)
6380 mpz_set_si (result
->value
.integer
, 0);
6382 mpz_set_si (result
->value
.integer
, 1);
6389 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
6394 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6397 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6402 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6403 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6404 return range_check (result
, "OR");
6407 return gfc_get_logical_expr (kind
, &x
->where
,
6408 x
->value
.logical
|| y
->value
.logical
);
6416 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
6419 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
6421 if (!is_constant_array_expr (array
)
6422 || !is_constant_array_expr (vector
)
6423 || (!gfc_is_constant_expr (mask
)
6424 && !is_constant_array_expr (mask
)))
6427 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
6428 if (array
->ts
.type
== BT_DERIVED
)
6429 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
6431 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
6432 vector_ctor
= vector
6433 ? gfc_constructor_first (vector
->value
.constructor
)
6436 if (mask
->expr_type
== EXPR_CONSTANT
6437 && mask
->value
.logical
)
6439 /* Copy all elements of ARRAY to RESULT. */
6442 gfc_constructor_append_expr (&result
->value
.constructor
,
6443 gfc_copy_expr (array_ctor
->expr
),
6446 array_ctor
= gfc_constructor_next (array_ctor
);
6447 vector_ctor
= gfc_constructor_next (vector_ctor
);
6450 else if (mask
->expr_type
== EXPR_ARRAY
)
6452 /* Copy only those elements of ARRAY to RESULT whose
6453 MASK equals .TRUE.. */
6454 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6457 if (mask_ctor
->expr
->value
.logical
)
6459 gfc_constructor_append_expr (&result
->value
.constructor
,
6460 gfc_copy_expr (array_ctor
->expr
),
6462 vector_ctor
= gfc_constructor_next (vector_ctor
);
6465 array_ctor
= gfc_constructor_next (array_ctor
);
6466 mask_ctor
= gfc_constructor_next (mask_ctor
);
6470 /* Append any left-over elements from VECTOR to RESULT. */
6473 gfc_constructor_append_expr (&result
->value
.constructor
,
6474 gfc_copy_expr (vector_ctor
->expr
),
6476 vector_ctor
= gfc_constructor_next (vector_ctor
);
6479 result
->shape
= gfc_get_shape (1);
6480 gfc_array_size (result
, &result
->shape
[0]);
6482 if (array
->ts
.type
== BT_CHARACTER
)
6483 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
6490 do_xor (gfc_expr
*result
, gfc_expr
*e
)
6492 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
6493 gcc_assert (result
->ts
.type
== BT_LOGICAL
6494 && result
->expr_type
== EXPR_CONSTANT
);
6496 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
6502 gfc_simplify_is_contiguous (gfc_expr
*array
)
6504 if (gfc_is_simply_contiguous (array
, false, true))
6505 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 1);
6507 if (gfc_is_not_contiguous (array
))
6508 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 0);
6515 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
6517 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
6522 gfc_simplify_popcnt (gfc_expr
*e
)
6527 if (e
->expr_type
!= EXPR_CONSTANT
)
6530 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6532 /* Convert argument to unsigned, then count the '1' bits. */
6533 mpz_init_set (x
, e
->value
.integer
);
6534 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
6535 res
= mpz_popcount (x
);
6538 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
6543 gfc_simplify_poppar (gfc_expr
*e
)
6548 if (e
->expr_type
!= EXPR_CONSTANT
)
6551 popcnt
= gfc_simplify_popcnt (e
);
6552 gcc_assert (popcnt
);
6554 bool fail
= gfc_extract_int (popcnt
, &i
);
6557 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
6562 gfc_simplify_precision (gfc_expr
*e
)
6564 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6565 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
6566 gfc_real_kinds
[i
].precision
);
6571 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6573 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
6578 gfc_simplify_radix (gfc_expr
*e
)
6581 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6586 i
= gfc_integer_kinds
[i
].radix
;
6590 i
= gfc_real_kinds
[i
].radix
;
6597 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6602 gfc_simplify_range (gfc_expr
*e
)
6605 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6610 i
= gfc_integer_kinds
[i
].range
;
6615 i
= gfc_real_kinds
[i
].range
;
6622 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6627 gfc_simplify_rank (gfc_expr
*e
)
6633 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
6638 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
6640 gfc_expr
*result
= NULL
;
6641 int kind
, tmp1
, tmp2
;
6643 /* Convert BOZ to real, and return without range checking. */
6644 if (e
->ts
.type
== BT_BOZ
)
6646 /* Determine kind for conversion of the BOZ. */
6648 gfc_extract_int (k
, &kind
);
6650 kind
= gfc_default_real_kind
;
6652 if (!gfc_boz2real (e
, kind
))
6654 result
= gfc_copy_expr (e
);
6658 if (e
->ts
.type
== BT_COMPLEX
)
6659 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
6661 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
6664 return &gfc_bad_expr
;
6666 if (e
->expr_type
!= EXPR_CONSTANT
)
6669 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
6671 tmp1
= warn_conversion
;
6672 tmp2
= warn_conversion_extra
;
6673 warn_conversion
= warn_conversion_extra
= 0;
6675 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
6677 warn_conversion
= tmp1
;
6678 warn_conversion_extra
= tmp2
;
6680 if (result
== &gfc_bad_expr
)
6681 return &gfc_bad_expr
;
6683 return range_check (result
, "REAL");
6688 gfc_simplify_realpart (gfc_expr
*e
)
6692 if (e
->expr_type
!= EXPR_CONSTANT
)
6695 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6696 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
6698 return range_check (result
, "REALPART");
6702 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
6707 bool have_length
= false;
6709 /* If NCOPIES isn't a constant, there's nothing we can do. */
6710 if (n
->expr_type
!= EXPR_CONSTANT
)
6713 /* If NCOPIES is negative, it's an error. */
6714 if (mpz_sgn (n
->value
.integer
) < 0)
6716 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6718 return &gfc_bad_expr
;
6721 /* If we don't know the character length, we can do no more. */
6722 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
6723 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6725 len
= gfc_mpz_get_hwi (e
->ts
.u
.cl
->length
->value
.integer
);
6728 else if (e
->expr_type
== EXPR_CONSTANT
6729 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
6731 len
= e
->value
.character
.length
;
6736 /* If the source length is 0, any value of NCOPIES is valid
6737 and everything behaves as if NCOPIES == 0. */
6740 mpz_set_ui (ncopies
, 0);
6742 mpz_set (ncopies
, n
->value
.integer
);
6744 /* Check that NCOPIES isn't too large. */
6750 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6752 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6756 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
6757 e
->ts
.u
.cl
->length
->value
.integer
);
6762 gfc_mpz_set_hwi (mlen
, len
);
6763 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
6767 /* The check itself. */
6768 if (mpz_cmp (ncopies
, max
) > 0)
6771 mpz_clear (ncopies
);
6772 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6774 return &gfc_bad_expr
;
6779 mpz_clear (ncopies
);
6781 /* For further simplification, we need the character string to be
6783 if (e
->expr_type
!= EXPR_CONSTANT
)
6788 (e
->ts
.u
.cl
->length
&&
6789 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
) != 0))
6791 bool fail
= gfc_extract_hwi (n
, &ncop
);
6798 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
6800 len
= e
->value
.character
.length
;
6801 gfc_charlen_t nlen
= ncop
* len
;
6803 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6804 (2**28 elements * 4 bytes (wide chars) per element) defer to
6805 runtime instead of consuming (unbounded) memory and CPU at
6807 if (nlen
> 268435456)
6809 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6810 " deferred to runtime, expect bugs", &e
->where
);
6814 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
6815 for (size_t i
= 0; i
< (size_t) ncop
; i
++)
6816 for (size_t j
= 0; j
< (size_t) len
; j
++)
6817 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
6819 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
6824 /* This one is a bear, but mainly has to do with shuffling elements. */
6827 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
6828 gfc_expr
*pad
, gfc_expr
*order_exp
)
6830 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
6831 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
6835 gfc_expr
*e
, *result
;
6836 bool zerosize
= false;
6838 /* Check that argument expression types are OK. */
6839 if (!is_constant_array_expr (source
)
6840 || !is_constant_array_expr (shape_exp
)
6841 || !is_constant_array_expr (pad
)
6842 || !is_constant_array_expr (order_exp
))
6845 if (source
->shape
== NULL
)
6848 /* Proceed with simplification, unpacking the array. */
6853 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
6858 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
6862 gfc_extract_int (e
, &shape
[rank
]);
6864 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
6865 if (shape
[rank
] < 0)
6867 gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
6868 "negative value %d for dimension %d",
6869 &shape_exp
->where
, shape
[rank
], rank
+1);
6870 return &gfc_bad_expr
;
6876 gcc_assert (rank
> 0);
6878 /* Now unpack the order array if present. */
6879 if (order_exp
== NULL
)
6881 for (i
= 0; i
< rank
; i
++)
6887 int order_size
, shape_size
;
6889 if (order_exp
->rank
!= shape_exp
->rank
)
6891 gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
6892 &order_exp
->where
, &shape_exp
->where
);
6893 return &gfc_bad_expr
;
6896 gfc_array_size (shape_exp
, &size
);
6897 shape_size
= mpz_get_ui (size
);
6899 gfc_array_size (order_exp
, &size
);
6900 order_size
= mpz_get_ui (size
);
6902 if (order_size
!= shape_size
)
6904 gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
6905 &order_exp
->where
, &shape_exp
->where
);
6906 return &gfc_bad_expr
;
6909 for (i
= 0; i
< rank
; i
++)
6911 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
6914 gfc_extract_int (e
, &order
[i
]);
6916 if (order
[i
] < 1 || order
[i
] > rank
)
6918 gfc_error ("Element with a value of %d in ORDER at %L must be "
6919 "in the range [1, ..., %d] for the RESHAPE intrinsic "
6920 "near %L", order
[i
], &order_exp
->where
, rank
,
6922 return &gfc_bad_expr
;
6926 if (x
[order
[i
]] != 0)
6928 gfc_error ("ORDER at %L is not a permutation of the size of "
6929 "SHAPE at %L", &order_exp
->where
, &shape_exp
->where
);
6930 return &gfc_bad_expr
;
6936 /* Count the elements in the source and padding arrays. */
6941 gfc_array_size (pad
, &size
);
6942 npad
= mpz_get_ui (size
);
6946 gfc_array_size (source
, &size
);
6947 nsource
= mpz_get_ui (size
);
6950 /* If it weren't for that pesky permutation we could just loop
6951 through the source and round out any shortage with pad elements.
6952 But no, someone just had to have the compiler do something the
6953 user should be doing. */
6955 for (i
= 0; i
< rank
; i
++)
6958 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6960 if (source
->ts
.type
== BT_DERIVED
)
6961 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6962 if (source
->ts
.type
== BT_CHARACTER
&& result
->ts
.u
.cl
== NULL
)
6963 result
->ts
= source
->ts
;
6964 result
->rank
= rank
;
6965 result
->shape
= gfc_get_shape (rank
);
6966 for (i
= 0; i
< rank
; i
++)
6968 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
6976 while (nsource
> 0 || npad
> 0)
6978 /* Figure out which element to extract. */
6979 mpz_set_ui (index
, 0);
6981 for (i
= rank
- 1; i
>= 0; i
--)
6983 mpz_add_ui (index
, index
, x
[order
[i
]]);
6985 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
6988 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
6989 gfc_internal_error ("Reshaped array too large at %C");
6991 j
= mpz_get_ui (index
);
6994 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
7004 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
7008 gfc_constructor_append_expr (&result
->value
.constructor
,
7009 gfc_copy_expr (e
), &e
->where
);
7011 /* Calculate the next element. */
7015 if (++x
[i
] < shape
[i
])
7033 gfc_simplify_rrspacing (gfc_expr
*x
)
7039 if (x
->expr_type
!= EXPR_CONSTANT
)
7042 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7044 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7046 /* RRSPACING(+/- 0.0) = 0.0 */
7047 if (mpfr_zero_p (x
->value
.real
))
7049 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7053 /* RRSPACING(inf) = NaN */
7054 if (mpfr_inf_p (x
->value
.real
))
7056 mpfr_set_nan (result
->value
.real
);
7060 /* RRSPACING(NaN) = same NaN */
7061 if (mpfr_nan_p (x
->value
.real
))
7063 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7067 /* | x * 2**(-e) | * 2**p. */
7068 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7069 e
= - (long int) mpfr_get_exp (x
->value
.real
);
7070 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
7072 p
= (long int) gfc_real_kinds
[i
].digits
;
7073 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
7075 return range_check (result
, "RRSPACING");
7080 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
7082 int k
, neg_flag
, power
, exp_range
;
7083 mpfr_t scale
, radix
;
7086 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7089 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7091 if (mpfr_zero_p (x
->value
.real
))
7093 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7097 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
7099 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
7101 /* This check filters out values of i that would overflow an int. */
7102 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
7103 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
7105 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
7106 gfc_free_expr (result
);
7107 return &gfc_bad_expr
;
7110 /* Compute scale = radix ** power. */
7111 power
= mpz_get_si (i
->value
.integer
);
7121 gfc_set_model_kind (x
->ts
.kind
);
7124 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
7125 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
7128 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7130 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7132 mpfr_clears (scale
, radix
, NULL
);
7134 return range_check (result
, "SCALE");
7138 /* Variants of strspn and strcspn that operate on wide characters. */
7141 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7144 const gfc_char_t
*c
;
7148 for (c
= s2
; *c
; c
++)
7162 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7165 const gfc_char_t
*c
;
7169 for (c
= s2
; *c
; c
++)
7184 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
7189 size_t indx
, len
, lenc
;
7190 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
7193 return &gfc_bad_expr
;
7195 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
7196 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
7199 if (b
!= NULL
&& b
->value
.logical
!= 0)
7204 len
= e
->value
.character
.length
;
7205 lenc
= c
->value
.character
.length
;
7207 if (len
== 0 || lenc
== 0)
7215 indx
= wide_strcspn (e
->value
.character
.string
,
7216 c
->value
.character
.string
) + 1;
7221 for (indx
= len
; indx
> 0; indx
--)
7223 for (i
= 0; i
< lenc
; i
++)
7225 if (c
->value
.character
.string
[i
]
7226 == e
->value
.character
.string
[indx
- 1])
7234 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
7235 return range_check (result
, "SCAN");
7240 gfc_simplify_selected_char_kind (gfc_expr
*e
)
7244 if (e
->expr_type
!= EXPR_CONSTANT
)
7247 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
7248 || gfc_compare_with_Cstring (e
, "default", false) == 0)
7250 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
7255 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7260 gfc_simplify_selected_int_kind (gfc_expr
*e
)
7264 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
))
7269 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
7270 if (gfc_integer_kinds
[i
].range
>= range
7271 && gfc_integer_kinds
[i
].kind
< kind
)
7272 kind
= gfc_integer_kinds
[i
].kind
;
7274 if (kind
== INT_MAX
)
7277 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7282 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
7284 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
7286 locus
*loc
= &gfc_current_locus
;
7292 if (p
->expr_type
!= EXPR_CONSTANT
7293 || gfc_extract_int (p
, &precision
))
7302 if (q
->expr_type
!= EXPR_CONSTANT
7303 || gfc_extract_int (q
, &range
))
7314 if (rdx
->expr_type
!= EXPR_CONSTANT
7315 || gfc_extract_int (rdx
, &radix
))
7323 found_precision
= 0;
7327 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
7329 if (gfc_real_kinds
[i
].precision
>= precision
)
7330 found_precision
= 1;
7332 if (gfc_real_kinds
[i
].range
>= range
)
7335 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7338 if (gfc_real_kinds
[i
].precision
>= precision
7339 && gfc_real_kinds
[i
].range
>= range
7340 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7341 && gfc_real_kinds
[i
].kind
< kind
)
7342 kind
= gfc_real_kinds
[i
].kind
;
7345 if (kind
== INT_MAX
)
7347 if (found_radix
&& found_range
&& !found_precision
)
7349 else if (found_radix
&& found_precision
&& !found_range
)
7351 else if (found_radix
&& !found_precision
&& !found_range
)
7353 else if (found_radix
)
7359 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
7364 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
7367 mpfr_t exp
, absv
, log2
, pow2
, frac
;
7370 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7373 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7375 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7376 SET_EXPONENT (NaN) = same NaN */
7377 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
7379 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7383 /* SET_EXPONENT (inf) = NaN */
7384 if (mpfr_inf_p (x
->value
.real
))
7386 mpfr_set_nan (result
->value
.real
);
7390 gfc_set_model_kind (x
->ts
.kind
);
7397 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
7398 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
7400 mpfr_trunc (log2
, log2
);
7401 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
7403 /* Old exponent value, and fraction. */
7404 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
7406 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
7409 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
7410 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
7412 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
7414 return range_check (result
, "SET_EXPONENT");
7419 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
7421 mpz_t shape
[GFC_MAX_DIMENSIONS
];
7422 gfc_expr
*result
, *e
, *f
;
7426 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
7428 if (source
->rank
== -1)
7431 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
7432 result
->shape
= gfc_get_shape (1);
7433 mpz_init (result
->shape
[0]);
7435 if (source
->rank
== 0)
7438 if (source
->expr_type
== EXPR_VARIABLE
)
7440 ar
= gfc_find_array_ref (source
);
7441 t
= gfc_array_ref_shape (ar
, shape
);
7443 else if (source
->shape
)
7446 for (n
= 0; n
< source
->rank
; n
++)
7448 mpz_init (shape
[n
]);
7449 mpz_set (shape
[n
], source
->shape
[n
]);
7455 for (n
= 0; n
< source
->rank
; n
++)
7457 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
7460 mpz_set (e
->value
.integer
, shape
[n
]);
7463 mpz_set_ui (e
->value
.integer
, n
+ 1);
7465 f
= simplify_size (source
, e
, k
);
7469 gfc_free_expr (result
);
7476 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
7478 gfc_free_expr (result
);
7480 gfc_clear_shape (shape
, source
->rank
);
7481 return &gfc_bad_expr
;
7484 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
7488 gfc_clear_shape (shape
, source
->rank
);
7490 mpz_set_si (result
->shape
[0], source
->rank
);
7497 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
7500 gfc_expr
*return_value
;
7504 /* For unary operations, the size of the result is given by the size
7505 of the operand. For binary ones, it's the size of the first operand
7506 unless it is scalar, then it is the size of the second. */
7507 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
7509 gfc_expr
* replacement
;
7510 gfc_expr
* simplified
;
7512 switch (array
->value
.op
.op
)
7514 /* Unary operations. */
7516 case INTRINSIC_UPLUS
:
7517 case INTRINSIC_UMINUS
:
7518 case INTRINSIC_PARENTHESES
:
7519 replacement
= array
->value
.op
.op1
;
7522 /* Binary operations. If any one of the operands is scalar, take
7523 the other one's size. If both of them are arrays, it does not
7524 matter -- try to find one with known shape, if possible. */
7526 if (array
->value
.op
.op1
->rank
== 0)
7527 replacement
= array
->value
.op
.op2
;
7528 else if (array
->value
.op
.op2
->rank
== 0)
7529 replacement
= array
->value
.op
.op1
;
7532 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
7536 replacement
= array
->value
.op
.op2
;
7541 /* Try to reduce it directly if possible. */
7542 simplified
= simplify_size (replacement
, dim
, k
);
7544 /* Otherwise, we build a new SIZE call. This is hopefully at least
7545 simpler than the original one. */
7548 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
7549 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
7550 GFC_ISYM_SIZE
, "size",
7552 gfc_copy_expr (replacement
),
7553 gfc_copy_expr (dim
),
7559 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
7560 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
)
7561 gfc_resolve_array_spec (ref
->u
.ar
.as
, 0);
7565 if (!gfc_array_size (array
, &size
))
7570 if (dim
->expr_type
!= EXPR_CONSTANT
)
7573 d
= mpz_get_ui (dim
->value
.integer
) - 1;
7574 if (!gfc_array_dimen_size (array
, d
, &size
))
7578 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
7579 mpz_set (return_value
->value
.integer
, size
);
7582 return return_value
;
7587 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
7590 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
7593 return &gfc_bad_expr
;
7595 result
= simplify_size (array
, dim
, k
);
7596 if (result
== NULL
|| result
== &gfc_bad_expr
)
7599 return range_check (result
, "SIZE");
7603 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
7604 multiplied by the array size. */
7607 gfc_simplify_sizeof (gfc_expr
*x
)
7609 gfc_expr
*result
= NULL
;
7613 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7616 if (x
->ts
.type
== BT_CHARACTER
7617 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7618 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7621 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
7622 && !gfc_array_size (x
, &array_size
))
7625 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
7627 gfc_target_expr_size (x
, &res_size
);
7628 mpz_set_si (result
->value
.integer
, res_size
);
7634 /* STORAGE_SIZE returns the size in bits of a single array element. */
7637 gfc_simplify_storage_size (gfc_expr
*x
,
7640 gfc_expr
*result
= NULL
;
7644 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7647 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
7648 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7649 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7652 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
7654 return &gfc_bad_expr
;
7656 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
7658 gfc_element_size (x
, &siz
);
7659 mpz_set_si (result
->value
.integer
, siz
);
7660 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
7662 return range_check (result
, "STORAGE_SIZE");
7667 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
7671 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
7674 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7679 mpz_abs (result
->value
.integer
, x
->value
.integer
);
7680 if (mpz_sgn (y
->value
.integer
) < 0)
7681 mpz_neg (result
->value
.integer
, result
->value
.integer
);
7686 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
7689 mpfr_setsign (result
->value
.real
, x
->value
.real
,
7690 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
7694 gfc_internal_error ("Bad type in gfc_simplify_sign");
7702 gfc_simplify_sin (gfc_expr
*x
)
7706 if (x
->expr_type
!= EXPR_CONSTANT
)
7709 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7714 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7718 gfc_set_model (x
->value
.real
);
7719 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7723 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
7726 return range_check (result
, "SIN");
7731 gfc_simplify_sinh (gfc_expr
*x
)
7735 if (x
->expr_type
!= EXPR_CONSTANT
)
7738 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7743 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7747 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7754 return range_check (result
, "SINH");
7758 /* The argument is always a double precision real that is converted to
7759 single precision. TODO: Rounding! */
7762 gfc_simplify_sngl (gfc_expr
*a
)
7767 if (a
->expr_type
!= EXPR_CONSTANT
)
7770 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
7772 tmp1
= warn_conversion
;
7773 tmp2
= warn_conversion_extra
;
7774 warn_conversion
= warn_conversion_extra
= 0;
7776 result
= gfc_real2real (a
, gfc_default_real_kind
);
7778 warn_conversion
= tmp1
;
7779 warn_conversion_extra
= tmp2
;
7781 return range_check (result
, "SNGL");
7786 gfc_simplify_spacing (gfc_expr
*x
)
7792 if (x
->expr_type
!= EXPR_CONSTANT
)
7795 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7796 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7798 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
7799 if (mpfr_zero_p (x
->value
.real
))
7801 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
7805 /* SPACING(inf) = NaN */
7806 if (mpfr_inf_p (x
->value
.real
))
7808 mpfr_set_nan (result
->value
.real
);
7812 /* SPACING(NaN) = same NaN */
7813 if (mpfr_nan_p (x
->value
.real
))
7815 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7819 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
7820 are the radix, exponent of x, and precision. This excludes the
7821 possibility of subnormal numbers. Fortran 2003 states the result is
7822 b**max(e - p, emin - 1). */
7824 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
7825 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
7826 en
= en
> ep
? en
: ep
;
7828 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
7829 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
7831 return range_check (result
, "SPACING");
7836 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
7838 gfc_expr
*result
= NULL
;
7839 int nelem
, i
, j
, dim
, ncopies
;
7842 if ((!gfc_is_constant_expr (source
)
7843 && !is_constant_array_expr (source
))
7844 || !gfc_is_constant_expr (dim_expr
)
7845 || !gfc_is_constant_expr (ncopies_expr
))
7848 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
7849 gfc_extract_int (dim_expr
, &dim
);
7850 dim
-= 1; /* zero-base DIM */
7852 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
7853 gfc_extract_int (ncopies_expr
, &ncopies
);
7854 ncopies
= MAX (ncopies
, 0);
7856 /* Do not allow the array size to exceed the limit for an array
7858 if (source
->expr_type
== EXPR_ARRAY
)
7860 if (!gfc_array_size (source
, &size
))
7861 gfc_internal_error ("Failure getting length of a constant array.");
7864 mpz_init_set_ui (size
, 1);
7866 nelem
= mpz_get_si (size
) * ncopies
;
7867 if (nelem
> flag_max_array_constructor
)
7869 if (gfc_init_expr_flag
)
7871 gfc_error ("The number of elements (%d) in the array constructor "
7872 "at %L requires an increase of the allowed %d upper "
7873 "limit. See %<-fmax-array-constructor%> option.",
7874 nelem
, &source
->where
, flag_max_array_constructor
);
7875 return &gfc_bad_expr
;
7881 if (source
->expr_type
== EXPR_CONSTANT
7882 || source
->expr_type
== EXPR_STRUCTURE
)
7884 gcc_assert (dim
== 0);
7886 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7888 if (source
->ts
.type
== BT_DERIVED
)
7889 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7891 result
->shape
= gfc_get_shape (result
->rank
);
7892 mpz_init_set_si (result
->shape
[0], ncopies
);
7894 for (i
= 0; i
< ncopies
; ++i
)
7895 gfc_constructor_append_expr (&result
->value
.constructor
,
7896 gfc_copy_expr (source
), NULL
);
7898 else if (source
->expr_type
== EXPR_ARRAY
)
7900 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
7901 gfc_constructor
*source_ctor
;
7903 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
7904 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
7906 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7908 if (source
->ts
.type
== BT_DERIVED
)
7909 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7910 result
->rank
= source
->rank
+ 1;
7911 result
->shape
= gfc_get_shape (result
->rank
);
7913 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
7916 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
7918 mpz_init_set_si (result
->shape
[i
], ncopies
);
7920 extent
[i
] = mpz_get_si (result
->shape
[i
]);
7921 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
7925 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
7926 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
7928 for (i
= 0; i
< ncopies
; ++i
)
7929 gfc_constructor_insert_expr (&result
->value
.constructor
,
7930 gfc_copy_expr (source_ctor
->expr
),
7931 NULL
, offset
+ i
* rstride
[dim
]);
7933 offset
+= (dim
== 0 ? ncopies
: 1);
7938 gfc_error ("Simplification of SPREAD at %C not yet implemented");
7939 return &gfc_bad_expr
;
7942 if (source
->ts
.type
== BT_CHARACTER
)
7943 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
7950 gfc_simplify_sqrt (gfc_expr
*e
)
7952 gfc_expr
*result
= NULL
;
7954 if (e
->expr_type
!= EXPR_CONSTANT
)
7960 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
7962 gfc_error ("Argument of SQRT at %L has a negative value",
7964 return &gfc_bad_expr
;
7966 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7967 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
7971 gfc_set_model (e
->value
.real
);
7973 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7974 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
7978 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
7981 return range_check (result
, "SQRT");
7986 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
7988 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
7992 /* Simplify COTAN(X) where X has the unit of radian. */
7995 gfc_simplify_cotan (gfc_expr
*x
)
8000 if (x
->expr_type
!= EXPR_CONSTANT
)
8003 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8008 mpfr_cot (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8012 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
8013 val
= &result
->value
.complex;
8014 mpc_init2 (swp
, mpfr_get_default_prec ());
8015 mpc_sin_cos (*val
, swp
, x
->value
.complex, GFC_MPC_RND_MODE
,
8017 mpc_div (*val
, swp
, *val
, GFC_MPC_RND_MODE
);
8025 return range_check (result
, "COTAN");
8030 gfc_simplify_tan (gfc_expr
*x
)
8034 if (x
->expr_type
!= EXPR_CONSTANT
)
8037 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8042 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8046 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8053 return range_check (result
, "TAN");
8058 gfc_simplify_tanh (gfc_expr
*x
)
8062 if (x
->expr_type
!= EXPR_CONSTANT
)
8065 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8070 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8074 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8081 return range_check (result
, "TANH");
8086 gfc_simplify_tiny (gfc_expr
*e
)
8091 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
8093 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
8094 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
8101 gfc_simplify_trailz (gfc_expr
*e
)
8103 unsigned long tz
, bs
;
8106 if (e
->expr_type
!= EXPR_CONSTANT
)
8109 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
8110 bs
= gfc_integer_kinds
[i
].bit_size
;
8111 tz
= mpz_scan1 (e
->value
.integer
, 0);
8113 return gfc_get_int_expr (gfc_default_integer_kind
,
8114 &e
->where
, MIN (tz
, bs
));
8119 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
8122 gfc_expr
*mold_element
;
8127 unsigned char *buffer
;
8128 size_t result_length
;
8130 if (!gfc_is_constant_expr (source
) || !gfc_is_constant_expr (size
))
8133 if (!gfc_resolve_expr (mold
))
8135 if (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
8138 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
8139 &result_size
, &result_length
))
8142 /* Calculate the size of the source. */
8143 if (source
->expr_type
== EXPR_ARRAY
&& !gfc_array_size (source
, &tmp
))
8144 gfc_internal_error ("Failure getting length of a constant array.");
8146 /* Create an empty new expression with the appropriate characteristics. */
8147 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
8149 result
->ts
= mold
->ts
;
8151 mold_element
= (mold
->expr_type
== EXPR_ARRAY
&& mold
->value
.constructor
)
8152 ? gfc_constructor_first (mold
->value
.constructor
)->expr
8155 /* Set result character length, if needed. Note that this needs to be
8156 set even for array expressions, in order to pass this information into
8157 gfc_target_interpret_expr. */
8158 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
8159 result
->value
.character
.length
= mold_element
->value
.character
.length
;
8161 /* Set the number of elements in the result, and determine its size. */
8163 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
8165 result
->expr_type
= EXPR_ARRAY
;
8167 result
->shape
= gfc_get_shape (1);
8168 mpz_init_set_ui (result
->shape
[0], result_length
);
8173 /* Allocate the buffer to store the binary version of the source. */
8174 buffer_size
= MAX (source_size
, result_size
);
8175 buffer
= (unsigned char*)alloca (buffer_size
);
8176 memset (buffer
, 0, buffer_size
);
8178 /* Now write source to the buffer. */
8179 gfc_target_encode_expr (source
, buffer
, buffer_size
);
8181 /* And read the buffer back into the new expression. */
8182 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
8189 gfc_simplify_transpose (gfc_expr
*matrix
)
8191 int row
, matrix_rows
, col
, matrix_cols
;
8194 if (!is_constant_array_expr (matrix
))
8197 gcc_assert (matrix
->rank
== 2);
8199 if (matrix
->shape
== NULL
)
8202 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
8205 result
->shape
= gfc_get_shape (result
->rank
);
8206 mpz_init_set (result
->shape
[0], matrix
->shape
[1]);
8207 mpz_init_set (result
->shape
[1], matrix
->shape
[0]);
8209 if (matrix
->ts
.type
== BT_CHARACTER
)
8210 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
8211 else if (matrix
->ts
.type
== BT_DERIVED
)
8212 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
8214 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
8215 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
8216 for (row
= 0; row
< matrix_rows
; ++row
)
8217 for (col
= 0; col
< matrix_cols
; ++col
)
8219 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
8220 col
* matrix_rows
+ row
);
8221 gfc_constructor_insert_expr (&result
->value
.constructor
,
8222 gfc_copy_expr (e
), &matrix
->where
,
8223 row
* matrix_cols
+ col
);
8231 gfc_simplify_trim (gfc_expr
*e
)
8234 int count
, i
, len
, lentrim
;
8236 if (e
->expr_type
!= EXPR_CONSTANT
)
8239 len
= e
->value
.character
.length
;
8240 for (count
= 0, i
= 1; i
<= len
; ++i
)
8242 if (e
->value
.character
.string
[len
- i
] == ' ')
8248 lentrim
= len
- count
;
8250 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
8251 for (i
= 0; i
< lentrim
; i
++)
8252 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
8259 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
8264 gfc_constructor
*sub_cons
;
8268 if (!is_constant_array_expr (sub
))
8271 /* Follow any component references. */
8272 as
= coarray
->symtree
->n
.sym
->as
;
8273 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
8274 if (ref
->type
== REF_COMPONENT
)
8277 if (as
->type
== AS_DEFERRED
)
8280 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
8281 the cosubscript addresses the first image. */
8283 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
8286 for (d
= 1; d
<= as
->corank
; d
++)
8291 gcc_assert (sub_cons
!= NULL
);
8293 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
8295 if (ca_bound
== NULL
)
8298 if (ca_bound
== &gfc_bad_expr
)
8301 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
8305 gfc_free_expr (ca_bound
);
8306 sub_cons
= gfc_constructor_next (sub_cons
);
8310 first_image
= false;
8314 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8315 "SUB has %ld and COARRAY lower bound is %ld)",
8317 mpz_get_si (sub_cons
->expr
->value
.integer
),
8318 mpz_get_si (ca_bound
->value
.integer
));
8319 gfc_free_expr (ca_bound
);
8320 return &gfc_bad_expr
;
8323 gfc_free_expr (ca_bound
);
8325 /* Check whether upperbound is valid for the multi-images case. */
8328 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
8330 if (ca_bound
== &gfc_bad_expr
)
8333 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
8334 && mpz_cmp (ca_bound
->value
.integer
,
8335 sub_cons
->expr
->value
.integer
) < 0)
8337 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8338 "SUB has %ld and COARRAY upper bound is %ld)",
8340 mpz_get_si (sub_cons
->expr
->value
.integer
),
8341 mpz_get_si (ca_bound
->value
.integer
));
8342 gfc_free_expr (ca_bound
);
8343 return &gfc_bad_expr
;
8347 gfc_free_expr (ca_bound
);
8350 sub_cons
= gfc_constructor_next (sub_cons
);
8353 gcc_assert (sub_cons
== NULL
);
8355 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
8358 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8359 &gfc_current_locus
);
8361 mpz_set_si (result
->value
.integer
, 1);
8363 mpz_set_si (result
->value
.integer
, 0);
8369 gfc_simplify_image_status (gfc_expr
*image
, gfc_expr
*team ATTRIBUTE_UNUSED
)
8371 if (flag_coarray
== GFC_FCOARRAY_NONE
)
8373 gfc_current_locus
= *gfc_current_intrinsic_where
;
8374 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
8375 return &gfc_bad_expr
;
8378 /* Simplification is possible for fcoarray = single only. For all other modes
8379 the result depends on runtime conditions. */
8380 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8383 if (gfc_is_constant_expr (image
))
8386 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8388 if (mpz_get_si (image
->value
.integer
) == 1)
8389 mpz_set_si (result
->value
.integer
, 0);
8391 mpz_set_si (result
->value
.integer
, GFC_STAT_STOPPED_IMAGE
);
8400 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
8401 gfc_expr
*distance ATTRIBUTE_UNUSED
)
8403 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8406 /* If no coarray argument has been passed or when the first argument
8407 is actually a distance argment. */
8408 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
8411 /* FIXME: gfc_current_locus is wrong. */
8412 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8413 &gfc_current_locus
);
8414 mpz_set_si (result
->value
.integer
, 1);
8418 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
8419 return simplify_cobound (coarray
, dim
, NULL
, 0);
8424 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8426 return simplify_bound (array
, dim
, kind
, 1);
8430 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8432 return simplify_cobound (array
, dim
, kind
, 1);
8437 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
8439 gfc_expr
*result
, *e
;
8440 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
8442 if (!is_constant_array_expr (vector
)
8443 || !is_constant_array_expr (mask
)
8444 || (!gfc_is_constant_expr (field
)
8445 && !is_constant_array_expr (field
)))
8448 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
8450 if (vector
->ts
.type
== BT_DERIVED
)
8451 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
8452 result
->rank
= mask
->rank
;
8453 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
8455 if (vector
->ts
.type
== BT_CHARACTER
)
8456 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
8458 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
8459 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
8461 = field
->expr_type
== EXPR_ARRAY
8462 ? gfc_constructor_first (field
->value
.constructor
)
8467 if (mask_ctor
->expr
->value
.logical
)
8469 gcc_assert (vector_ctor
);
8470 e
= gfc_copy_expr (vector_ctor
->expr
);
8471 vector_ctor
= gfc_constructor_next (vector_ctor
);
8473 else if (field
->expr_type
== EXPR_ARRAY
)
8474 e
= gfc_copy_expr (field_ctor
->expr
);
8476 e
= gfc_copy_expr (field
);
8478 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
8480 mask_ctor
= gfc_constructor_next (mask_ctor
);
8481 field_ctor
= gfc_constructor_next (field_ctor
);
8489 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
8493 size_t index
, len
, lenset
;
8495 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
8498 return &gfc_bad_expr
;
8500 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
8501 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
8504 if (b
!= NULL
&& b
->value
.logical
!= 0)
8509 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
8511 len
= s
->value
.character
.length
;
8512 lenset
= set
->value
.character
.length
;
8516 mpz_set_ui (result
->value
.integer
, 0);
8524 mpz_set_ui (result
->value
.integer
, 1);
8528 index
= wide_strspn (s
->value
.character
.string
,
8529 set
->value
.character
.string
) + 1;
8538 mpz_set_ui (result
->value
.integer
, len
);
8541 for (index
= len
; index
> 0; index
--)
8543 for (i
= 0; i
< lenset
; i
++)
8545 if (s
->value
.character
.string
[index
- 1]
8546 == set
->value
.character
.string
[i
])
8554 mpz_set_ui (result
->value
.integer
, index
);
8560 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
8565 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
8568 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
8573 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
8574 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
8575 return range_check (result
, "XOR");
8578 return gfc_get_logical_expr (kind
, &x
->where
,
8579 (x
->value
.logical
&& !y
->value
.logical
)
8580 || (!x
->value
.logical
&& y
->value
.logical
));
8588 /****************** Constant simplification *****************/
8590 /* Master function to convert one constant to another. While this is
8591 used as a simplification function, it requires the destination type
8592 and kind information which is supplied by a special case in
8596 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
8598 gfc_expr
*result
, *(*f
) (gfc_expr
*, int);
8599 gfc_constructor
*c
, *t
;
8613 f
= gfc_int2complex
;
8633 f
= gfc_real2complex
;
8644 f
= gfc_complex2int
;
8647 f
= gfc_complex2real
;
8650 f
= gfc_complex2complex
;
8676 f
= gfc_hollerith2int
;
8680 f
= gfc_hollerith2real
;
8684 f
= gfc_hollerith2complex
;
8688 f
= gfc_hollerith2character
;
8692 f
= gfc_hollerith2logical
;
8704 f
= gfc_character2int
;
8708 f
= gfc_character2real
;
8712 f
= gfc_character2complex
;
8716 f
= gfc_character2character
;
8720 f
= gfc_character2logical
;
8730 return &gfc_bad_expr
;
8735 switch (e
->expr_type
)
8738 result
= f (e
, kind
);
8740 return &gfc_bad_expr
;
8744 if (!gfc_is_constant_expr (e
))
8747 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8748 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8749 result
->rank
= e
->rank
;
8751 for (c
= gfc_constructor_first (e
->value
.constructor
);
8752 c
; c
= gfc_constructor_next (c
))
8755 if (c
->iterator
== NULL
)
8757 if (c
->expr
->expr_type
== EXPR_ARRAY
)
8758 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8759 else if (c
->expr
->expr_type
== EXPR_OP
)
8761 if (!gfc_simplify_expr (c
->expr
, 1))
8762 return &gfc_bad_expr
;
8763 tmp
= f (c
->expr
, kind
);
8766 tmp
= f (c
->expr
, kind
);
8769 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8771 if (tmp
== NULL
|| tmp
== &gfc_bad_expr
)
8773 gfc_free_expr (result
);
8777 t
= gfc_constructor_append_expr (&result
->value
.constructor
,
8780 t
->iterator
= gfc_copy_iterator (c
->iterator
);
8793 /* Function for converting character constants. */
8795 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
8800 if (!gfc_is_constant_expr (e
))
8803 if (e
->expr_type
== EXPR_CONSTANT
)
8805 /* Simple case of a scalar. */
8806 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
8808 return &gfc_bad_expr
;
8810 result
->value
.character
.length
= e
->value
.character
.length
;
8811 result
->value
.character
.string
8812 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
8813 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
8814 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
8816 /* Check we only have values representable in the destination kind. */
8817 for (i
= 0; i
< result
->value
.character
.length
; i
++)
8818 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
8821 gfc_error ("Character %qs in string at %L cannot be converted "
8822 "into character kind %d",
8823 gfc_print_wide_char (result
->value
.character
.string
[i
]),
8825 gfc_free_expr (result
);
8826 return &gfc_bad_expr
;
8831 else if (e
->expr_type
== EXPR_ARRAY
)
8833 /* For an array constructor, we convert each constructor element. */
8836 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8837 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8838 result
->rank
= e
->rank
;
8839 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
8841 for (c
= gfc_constructor_first (e
->value
.constructor
);
8842 c
; c
= gfc_constructor_next (c
))
8844 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
8845 if (tmp
== &gfc_bad_expr
)
8847 gfc_free_expr (result
);
8848 return &gfc_bad_expr
;
8853 gfc_free_expr (result
);
8857 gfc_constructor_append_expr (&result
->value
.constructor
,
8869 gfc_simplify_compiler_options (void)
8874 str
= gfc_get_option_string ();
8875 result
= gfc_get_character_expr (gfc_default_character_kind
,
8876 &gfc_current_locus
, str
, strlen (str
));
8883 gfc_simplify_compiler_version (void)
8888 len
= strlen ("GCC version ") + strlen (version_string
);
8889 buffer
= XALLOCAVEC (char, len
+ 1);
8890 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
8891 return gfc_get_character_expr (gfc_default_character_kind
,
8892 &gfc_current_locus
, buffer
, len
);
8895 /* Simplification routines for intrinsics of IEEE modules. */
8898 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
8900 gfc_actual_arglist
*arg
;
8901 gfc_expr
*p
= NULL
, *q
= NULL
, *rdx
= NULL
;
8903 arg
= expr
->value
.function
.actual
;
8907 q
= arg
->next
->expr
;
8908 if (arg
->next
->next
)
8909 rdx
= arg
->next
->next
->expr
;
8912 /* Currently, if IEEE is supported and this module is built, it means
8913 all our floating-point types conform to IEEE. Hence, we simply handle
8914 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
8915 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
8919 simplify_ieee_support (gfc_expr
*expr
)
8921 /* We consider that if the IEEE modules are loaded, we have full support
8922 for flags, halting and rounding, which are the three functions
8923 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
8924 expressions. One day, we will need libgfortran to detect support and
8925 communicate it back to us, allowing for partial support. */
8927 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
8932 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
8934 int n
= strlen(name
);
8936 if (!strncmp(sym
->name
, name
, n
))
8939 /* If a generic was used and renamed, we need more work to find out.
8940 Compare the specific name. */
8941 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
8948 gfc_simplify_ieee_functions (gfc_expr
*expr
)
8950 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
8952 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
8953 return simplify_ieee_selected_real_kind (expr
);
8954 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
8955 || matches_ieee_function_name(sym
, "ieee_support_halting")
8956 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
8957 return simplify_ieee_support (expr
);