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
)
5099 gfc_actual_arglist
*arg
, *last
, *extremum
;
5100 gfc_expr
*tmp
, *ret
;
5106 arg
= expr
->value
.function
.actual
;
5108 for (; arg
; last
= arg
, arg
= arg
->next
)
5110 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
5113 if (extremum
== NULL
)
5119 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
5121 /* Delete the extra constant argument. */
5122 last
->next
= arg
->next
;
5125 gfc_free_actual_arglist (arg
);
5129 /* If there is one value left, replace the function call with the
5131 if (expr
->value
.function
.actual
->next
!= NULL
)
5134 /* Handle special cases of specific functions (min|max)1 and
5137 tmp
= expr
->value
.function
.actual
->expr
;
5138 fname
= expr
->value
.function
.isym
->name
;
5140 if ((tmp
->ts
.type
!= BT_INTEGER
|| tmp
->ts
.kind
!= gfc_integer_4_kind
)
5141 && (strcmp (fname
, "min1") == 0 || strcmp (fname
, "max1") == 0))
5143 ret
= gfc_convert_constant (tmp
, BT_INTEGER
, gfc_integer_4_kind
);
5145 else if ((tmp
->ts
.type
!= BT_REAL
|| tmp
->ts
.kind
!= gfc_real_4_kind
)
5146 && (strcmp (fname
, "amin0") == 0 || strcmp (fname
, "amax0") == 0))
5148 ret
= gfc_convert_constant (tmp
, BT_REAL
, gfc_real_4_kind
);
5151 ret
= gfc_copy_expr (tmp
);
5159 gfc_simplify_min (gfc_expr
*e
)
5161 return simplify_min_max (e
, -1);
5166 gfc_simplify_max (gfc_expr
*e
)
5168 return simplify_min_max (e
, 1);
5171 /* Helper function for gfc_simplify_minval. */
5174 gfc_min (gfc_expr
*op1
, gfc_expr
*op2
)
5176 min_max_choose (op1
, op2
, -1);
5177 gfc_free_expr (op1
);
5181 /* Simplify minval for constant arrays. */
5184 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5186 return simplify_transformation (array
, dim
, mask
, INT_MAX
, gfc_min
);
5189 /* Helper function for gfc_simplify_maxval. */
5192 gfc_max (gfc_expr
*op1
, gfc_expr
*op2
)
5194 min_max_choose (op1
, op2
, 1);
5195 gfc_free_expr (op1
);
5200 /* Simplify maxval for constant arrays. */
5203 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5205 return simplify_transformation (array
, dim
, mask
, INT_MIN
, gfc_max
);
5209 /* Transform minloc or maxloc of an array, according to MASK,
5210 to the scalar result. This code is mostly identical to
5211 simplify_transformation_to_scalar. */
5214 simplify_minmaxloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
5215 gfc_expr
*extremum
, int sign
, bool back_val
)
5218 gfc_constructor
*array_ctor
, *mask_ctor
;
5221 mpz_set_si (result
->value
.integer
, 0);
5224 /* Shortcut for constant .FALSE. MASK. */
5226 && mask
->expr_type
== EXPR_CONSTANT
5227 && !mask
->value
.logical
)
5230 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5231 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5232 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5236 mpz_init_set_si (count
, 0);
5239 mpz_add_ui (count
, count
, 1);
5240 a
= array_ctor
->expr
;
5241 array_ctor
= gfc_constructor_next (array_ctor
);
5242 /* A constant MASK equals .TRUE. here and can be ignored. */
5245 m
= mask_ctor
->expr
;
5246 mask_ctor
= gfc_constructor_next (mask_ctor
);
5247 if (!m
->value
.logical
)
5250 if (min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5251 mpz_set (result
->value
.integer
, count
);
5254 gfc_free_expr (extremum
);
5258 /* Simplify minloc / maxloc in the absence of a dim argument. */
5261 simplify_minmaxloc_nodim (gfc_expr
*result
, gfc_expr
*extremum
,
5262 gfc_expr
*array
, gfc_expr
*mask
, int sign
,
5265 ssize_t res
[GFC_MAX_DIMENSIONS
];
5267 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5268 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5269 sstride
[GFC_MAX_DIMENSIONS
];
5274 for (i
= 0; i
<array
->rank
; i
++)
5277 /* Shortcut for constant .FALSE. MASK. */
5279 && mask
->expr_type
== EXPR_CONSTANT
5280 && !mask
->value
.logical
)
5283 for (i
= 0; i
< array
->rank
; i
++)
5286 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5287 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5292 continue_loop
= true;
5293 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5294 if (mask
&& mask
->rank
> 0)
5295 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5299 /* Loop over the array elements (and mask), keeping track of
5300 the indices to return. */
5301 while (continue_loop
)
5305 a
= array_ctor
->expr
;
5308 m
= mask_ctor
->expr
;
5309 ma
= m
->value
.logical
;
5310 mask_ctor
= gfc_constructor_next (mask_ctor
);
5315 if (ma
&& min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5317 for (i
= 0; i
<array
->rank
; i
++)
5320 array_ctor
= gfc_constructor_next (array_ctor
);
5322 } while (count
[0] != extent
[0]);
5326 /* When we get to the end of a dimension, reset it and increment
5327 the next dimension. */
5330 if (n
>= array
->rank
)
5332 continue_loop
= false;
5337 } while (count
[n
] == extent
[n
]);
5341 gfc_free_expr (extremum
);
5342 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5343 for (i
= 0; i
<array
->rank
; i
++)
5346 r_expr
= result_ctor
->expr
;
5347 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5348 result_ctor
= gfc_constructor_next (result_ctor
);
5353 /* Helper function for gfc_simplify_minmaxloc - build an array
5354 expression with n elements. */
5357 new_array (bt type
, int kind
, int n
, locus
*where
)
5362 result
= gfc_get_array_expr (type
, kind
, where
);
5364 result
->shape
= gfc_get_shape(1);
5365 mpz_init_set_si (result
->shape
[0], n
);
5366 for (i
= 0; i
< n
; i
++)
5368 gfc_constructor_append_expr (&result
->value
.constructor
,
5369 gfc_get_constant_expr (type
, kind
, where
),
5376 /* Simplify minloc and maxloc. This code is mostly identical to
5377 simplify_transformation_to_array. */
5380 simplify_minmaxloc_to_array (gfc_expr
*result
, gfc_expr
*array
,
5381 gfc_expr
*dim
, gfc_expr
*mask
,
5382 gfc_expr
*extremum
, int sign
, bool back_val
)
5385 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5386 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5387 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5389 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5390 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5391 tmpstride
[GFC_MAX_DIMENSIONS
];
5393 /* Shortcut for constant .FALSE. MASK. */
5395 && mask
->expr_type
== EXPR_CONSTANT
5396 && !mask
->value
.logical
)
5399 /* Build an indexed table for array element expressions to minimize
5400 linked-list traversal. Masked elements are set to NULL. */
5401 gfc_array_size (array
, &size
);
5402 arraysize
= mpz_get_ui (size
);
5405 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5407 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5409 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5410 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5412 for (i
= 0; i
< arraysize
; ++i
)
5414 arrayvec
[i
] = array_ctor
->expr
;
5415 array_ctor
= gfc_constructor_next (array_ctor
);
5419 if (!mask_ctor
->expr
->value
.logical
)
5422 mask_ctor
= gfc_constructor_next (mask_ctor
);
5426 /* Same for the result expression. */
5427 gfc_array_size (result
, &size
);
5428 resultsize
= mpz_get_ui (size
);
5431 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5432 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5433 for (i
= 0; i
< resultsize
; ++i
)
5435 resultvec
[i
] = result_ctor
->expr
;
5436 result_ctor
= gfc_constructor_next (result_ctor
);
5439 gfc_extract_int (dim
, &dim_index
);
5440 dim_index
-= 1; /* zero-base index */
5444 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5447 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5450 dim_extent
= mpz_get_si (array
->shape
[i
]);
5451 dim_stride
= tmpstride
[i
];
5455 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5456 sstride
[n
] = tmpstride
[i
];
5457 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5461 done
= resultsize
<= 0;
5467 ex
= gfc_copy_expr (extremum
);
5468 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5470 if (*src
&& min_max_choose (*src
, ex
, sign
, back_val
) > 0)
5471 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5480 while (!done
&& count
[n
] == extent
[n
])
5483 base
-= sstride
[n
] * extent
[n
];
5484 dest
-= dstride
[n
] * extent
[n
];
5487 if (n
< result
->rank
)
5489 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5490 times, we'd warn for the last iteration, because the
5491 array index will have already been incremented to the
5492 array sizes, and we can't tell that this must make
5493 the test against result->rank false, because ranks
5494 must not exceed GFC_MAX_DIMENSIONS. */
5495 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5506 /* Place updated expression in result constructor. */
5507 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5508 for (i
= 0; i
< resultsize
; ++i
)
5510 result_ctor
->expr
= resultvec
[i
];
5511 result_ctor
= gfc_constructor_next (result_ctor
);
5520 /* Simplify minloc and maxloc for constant arrays. */
5523 gfc_simplify_minmaxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
5524 gfc_expr
*kind
, gfc_expr
*back
, int sign
)
5530 bool back_val
= false;
5532 if (!is_constant_array_expr (array
)
5533 || !gfc_is_constant_expr (dim
))
5537 && !is_constant_array_expr (mask
)
5538 && mask
->expr_type
!= EXPR_CONSTANT
)
5543 if (gfc_extract_int (kind
, &ikind
, -1))
5547 ikind
= gfc_default_integer_kind
;
5551 if (back
->expr_type
!= EXPR_CONSTANT
)
5554 back_val
= back
->value
.logical
;
5564 extremum
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
5565 init_result_expr (extremum
, init_val
, array
);
5569 result
= transformational_result (array
, dim
, BT_INTEGER
,
5570 ikind
, &array
->where
);
5571 init_result_expr (result
, 0, array
);
5573 if (array
->rank
== 1)
5574 return simplify_minmaxloc_to_scalar (result
, array
, mask
, extremum
,
5577 return simplify_minmaxloc_to_array (result
, array
, dim
, mask
, extremum
,
5582 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5583 return simplify_minmaxloc_nodim (result
, extremum
, array
, mask
,
5589 gfc_simplify_minloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5592 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, -1);
5596 gfc_simplify_maxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5599 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, 1);
5602 /* Simplify findloc to scalar. Similar to
5603 simplify_minmaxloc_to_scalar. */
5606 simplify_findloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5607 gfc_expr
*mask
, int back_val
)
5610 gfc_constructor
*array_ctor
, *mask_ctor
;
5613 mpz_set_si (result
->value
.integer
, 0);
5615 /* Shortcut for constant .FALSE. MASK. */
5617 && mask
->expr_type
== EXPR_CONSTANT
5618 && !mask
->value
.logical
)
5621 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5622 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5623 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5627 mpz_init_set_si (count
, 0);
5630 mpz_add_ui (count
, count
, 1);
5631 a
= array_ctor
->expr
;
5632 array_ctor
= gfc_constructor_next (array_ctor
);
5633 /* A constant MASK equals .TRUE. here and can be ignored. */
5636 m
= mask_ctor
->expr
;
5637 mask_ctor
= gfc_constructor_next (mask_ctor
);
5638 if (!m
->value
.logical
)
5641 if (gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5643 /* We have a match. If BACK is true, continue so we find
5645 mpz_set (result
->value
.integer
, count
);
5654 /* Simplify findloc in the absence of a dim argument. Similar to
5655 simplify_minmaxloc_nodim. */
5658 simplify_findloc_nodim (gfc_expr
*result
, gfc_expr
*value
, gfc_expr
*array
,
5659 gfc_expr
*mask
, bool back_val
)
5661 ssize_t res
[GFC_MAX_DIMENSIONS
];
5663 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5664 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5665 sstride
[GFC_MAX_DIMENSIONS
];
5670 for (i
= 0; i
< array
->rank
; i
++)
5673 /* Shortcut for constant .FALSE. MASK. */
5675 && mask
->expr_type
== EXPR_CONSTANT
5676 && !mask
->value
.logical
)
5679 for (i
= 0; i
< array
->rank
; i
++)
5682 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5683 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5688 continue_loop
= true;
5689 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5690 if (mask
&& mask
->rank
> 0)
5691 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5695 /* Loop over the array elements (and mask), keeping track of
5696 the indices to return. */
5697 while (continue_loop
)
5701 a
= array_ctor
->expr
;
5704 m
= mask_ctor
->expr
;
5705 ma
= m
->value
.logical
;
5706 mask_ctor
= gfc_constructor_next (mask_ctor
);
5711 if (ma
&& gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5713 for (i
= 0; i
< array
->rank
; i
++)
5718 array_ctor
= gfc_constructor_next (array_ctor
);
5720 } while (count
[0] != extent
[0]);
5724 /* When we get to the end of a dimension, reset it and increment
5725 the next dimension. */
5728 if (n
>= array
->rank
)
5730 continue_loop
= false;
5735 } while (count
[n
] == extent
[n
]);
5739 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5740 for (i
= 0; i
< array
->rank
; i
++)
5743 r_expr
= result_ctor
->expr
;
5744 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5745 result_ctor
= gfc_constructor_next (result_ctor
);
5751 /* Simplify findloc to an array. Similar to
5752 simplify_minmaxloc_to_array. */
5755 simplify_findloc_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5756 gfc_expr
*dim
, gfc_expr
*mask
, bool back_val
)
5759 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5760 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5761 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5763 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5764 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5765 tmpstride
[GFC_MAX_DIMENSIONS
];
5767 /* Shortcut for constant .FALSE. MASK. */
5769 && mask
->expr_type
== EXPR_CONSTANT
5770 && !mask
->value
.logical
)
5773 /* Build an indexed table for array element expressions to minimize
5774 linked-list traversal. Masked elements are set to NULL. */
5775 gfc_array_size (array
, &size
);
5776 arraysize
= mpz_get_ui (size
);
5779 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5781 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5783 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5784 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5786 for (i
= 0; i
< arraysize
; ++i
)
5788 arrayvec
[i
] = array_ctor
->expr
;
5789 array_ctor
= gfc_constructor_next (array_ctor
);
5793 if (!mask_ctor
->expr
->value
.logical
)
5796 mask_ctor
= gfc_constructor_next (mask_ctor
);
5800 /* Same for the result expression. */
5801 gfc_array_size (result
, &size
);
5802 resultsize
= mpz_get_ui (size
);
5805 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5806 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5807 for (i
= 0; i
< resultsize
; ++i
)
5809 resultvec
[i
] = result_ctor
->expr
;
5810 result_ctor
= gfc_constructor_next (result_ctor
);
5813 gfc_extract_int (dim
, &dim_index
);
5815 dim_index
-= 1; /* Zero-base index. */
5819 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5822 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5825 dim_extent
= mpz_get_si (array
->shape
[i
]);
5826 dim_stride
= tmpstride
[i
];
5830 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5831 sstride
[n
] = tmpstride
[i
];
5832 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5836 done
= resultsize
<= 0;
5841 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5843 if (*src
&& gfc_compare_expr (*src
, value
, INTRINSIC_EQ
) == 0)
5845 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5856 while (!done
&& count
[n
] == extent
[n
])
5859 base
-= sstride
[n
] * extent
[n
];
5860 dest
-= dstride
[n
] * extent
[n
];
5863 if (n
< result
->rank
)
5865 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5866 times, we'd warn for the last iteration, because the
5867 array index will have already been incremented to the
5868 array sizes, and we can't tell that this must make
5869 the test against result->rank false, because ranks
5870 must not exceed GFC_MAX_DIMENSIONS. */
5871 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5882 /* Place updated expression in result constructor. */
5883 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5884 for (i
= 0; i
< resultsize
; ++i
)
5886 result_ctor
->expr
= resultvec
[i
];
5887 result_ctor
= gfc_constructor_next (result_ctor
);
5895 /* Simplify findloc. */
5898 gfc_simplify_findloc (gfc_expr
*array
, gfc_expr
*value
, gfc_expr
*dim
,
5899 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
5903 bool back_val
= false;
5905 if (!is_constant_array_expr (array
)
5906 || !gfc_is_constant_expr (dim
))
5909 if (! gfc_is_constant_expr (value
))
5913 && !is_constant_array_expr (mask
)
5914 && mask
->expr_type
!= EXPR_CONSTANT
)
5919 if (gfc_extract_int (kind
, &ikind
, -1))
5923 ikind
= gfc_default_integer_kind
;
5927 if (back
->expr_type
!= EXPR_CONSTANT
)
5930 back_val
= back
->value
.logical
;
5935 result
= transformational_result (array
, dim
, BT_INTEGER
,
5936 ikind
, &array
->where
);
5937 init_result_expr (result
, 0, array
);
5939 if (array
->rank
== 1)
5940 return simplify_findloc_to_scalar (result
, array
, value
, mask
,
5943 return simplify_findloc_to_array (result
, array
, value
, dim
, mask
,
5948 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5949 return simplify_findloc_nodim (result
, value
, array
, mask
, back_val
);
5955 gfc_simplify_maxexponent (gfc_expr
*x
)
5957 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5958 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5959 gfc_real_kinds
[i
].max_exponent
);
5964 gfc_simplify_minexponent (gfc_expr
*x
)
5966 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5967 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5968 gfc_real_kinds
[i
].min_exponent
);
5973 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
5978 /* First check p. */
5979 if (p
->expr_type
!= EXPR_CONSTANT
)
5982 /* p shall not be 0. */
5986 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
5988 gfc_error ("Argument %qs of MOD at %L shall not be zero",
5990 return &gfc_bad_expr
;
5994 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
5996 gfc_error ("Argument %qs of MOD at %L shall not be zero",
5998 return &gfc_bad_expr
;
6002 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6005 if (a
->expr_type
!= EXPR_CONSTANT
)
6008 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6009 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6011 if (a
->ts
.type
== BT_INTEGER
)
6012 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6015 gfc_set_model_kind (kind
);
6016 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6020 return range_check (result
, "MOD");
6025 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
6030 /* First check p. */
6031 if (p
->expr_type
!= EXPR_CONSTANT
)
6034 /* p shall not be 0. */
6038 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
6040 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6042 return &gfc_bad_expr
;
6046 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
6048 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6050 return &gfc_bad_expr
;
6054 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6057 if (a
->expr_type
!= EXPR_CONSTANT
)
6060 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6061 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6063 if (a
->ts
.type
== BT_INTEGER
)
6064 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6067 gfc_set_model_kind (kind
);
6068 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6070 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
6072 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
6073 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
6077 mpfr_copysign (result
->value
.real
, result
->value
.real
,
6078 p
->value
.real
, GFC_RND_MODE
);
6081 return range_check (result
, "MODULO");
6086 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
6089 mpfr_exp_t emin
, emax
;
6092 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
6095 result
= gfc_copy_expr (x
);
6097 /* Save current values of emin and emax. */
6098 emin
= mpfr_get_emin ();
6099 emax
= mpfr_get_emax ();
6101 /* Set emin and emax for the current model number. */
6102 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
6103 mpfr_set_emin ((mpfr_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
6104 mpfr_get_prec(result
->value
.real
) + 1);
6105 mpfr_set_emax ((mpfr_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
6106 mpfr_check_range (result
->value
.real
, 0, MPFR_RNDU
);
6108 if (mpfr_sgn (s
->value
.real
) > 0)
6110 mpfr_nextabove (result
->value
.real
);
6111 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDU
);
6115 mpfr_nextbelow (result
->value
.real
);
6116 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDD
);
6119 mpfr_set_emin (emin
);
6120 mpfr_set_emax (emax
);
6122 /* Only NaN can occur. Do not use range check as it gives an
6123 error for denormal numbers. */
6124 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
6126 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
6127 gfc_free_expr (result
);
6128 return &gfc_bad_expr
;
6136 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
6138 gfc_expr
*itrunc
, *result
;
6141 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
6143 return &gfc_bad_expr
;
6145 if (e
->expr_type
!= EXPR_CONSTANT
)
6148 itrunc
= gfc_copy_expr (e
);
6149 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
6151 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
6152 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
6154 gfc_free_expr (itrunc
);
6156 return range_check (result
, name
);
6161 gfc_simplify_new_line (gfc_expr
*e
)
6165 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
6166 result
->value
.character
.string
[0] = '\n';
6173 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
6175 return simplify_nint ("NINT", e
, k
);
6180 gfc_simplify_idnint (gfc_expr
*e
)
6182 return simplify_nint ("IDNINT", e
, NULL
);
6185 static int norm2_scale
;
6188 norm2_add_squared (gfc_expr
*result
, gfc_expr
*e
)
6192 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6193 gcc_assert (result
->ts
.type
== BT_REAL
6194 && result
->expr_type
== EXPR_CONSTANT
);
6196 gfc_set_model_kind (result
->ts
.kind
);
6197 int index
= gfc_validate_kind (BT_REAL
, result
->ts
.kind
, false);
6199 if (mpfr_regular_p (result
->value
.real
))
6201 exp
= mpfr_get_exp (result
->value
.real
);
6202 /* If result is getting close to overflowing, scale down. */
6203 if (exp
>= gfc_real_kinds
[index
].max_exponent
- 4
6204 && norm2_scale
<= gfc_real_kinds
[index
].max_exponent
- 2)
6207 mpfr_div_ui (result
->value
.real
, result
->value
.real
, 16,
6213 if (mpfr_regular_p (e
->value
.real
))
6215 exp
= mpfr_get_exp (e
->value
.real
);
6216 /* If e**2 would overflow or close to overflowing, scale down. */
6217 if (exp
- norm2_scale
>= gfc_real_kinds
[index
].max_exponent
/ 2 - 2)
6219 int new_scale
= gfc_real_kinds
[index
].max_exponent
/ 2 + 4;
6220 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6221 mpfr_set_exp (tmp
, new_scale
- norm2_scale
);
6222 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6223 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6224 norm2_scale
= new_scale
;
6229 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6230 mpfr_set_exp (tmp
, norm2_scale
);
6231 mpfr_div (tmp
, e
->value
.real
, tmp
, GFC_RND_MODE
);
6234 mpfr_set (tmp
, e
->value
.real
, GFC_RND_MODE
);
6235 mpfr_pow_ui (tmp
, tmp
, 2, GFC_RND_MODE
);
6236 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
6245 norm2_do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
6247 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6248 gcc_assert (result
->ts
.type
== BT_REAL
6249 && result
->expr_type
== EXPR_CONSTANT
);
6252 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6253 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6254 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6258 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6259 mpfr_set_exp (tmp
, norm2_scale
);
6260 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6270 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
6275 size_zero
= gfc_is_size_zero_array (e
);
6277 if (!(is_constant_array_expr (e
) || size_zero
)
6278 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
6281 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6282 init_result_expr (result
, 0, NULL
);
6288 if (!dim
|| e
->rank
== 1)
6290 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
6292 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6293 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6297 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6298 mpfr_set_exp (tmp
, norm2_scale
);
6299 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6305 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
6314 gfc_simplify_not (gfc_expr
*e
)
6318 if (e
->expr_type
!= EXPR_CONSTANT
)
6321 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6322 mpz_com (result
->value
.integer
, e
->value
.integer
);
6324 return range_check (result
, "NOT");
6329 gfc_simplify_null (gfc_expr
*mold
)
6335 result
= gfc_copy_expr (mold
);
6336 result
->expr_type
= EXPR_NULL
;
6339 result
= gfc_get_null_expr (NULL
);
6346 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
6350 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6352 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6353 return &gfc_bad_expr
;
6356 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6359 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
6362 /* FIXME: gfc_current_locus is wrong. */
6363 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6364 &gfc_current_locus
);
6366 if (failed
&& failed
->value
.logical
!= 0)
6367 mpz_set_si (result
->value
.integer
, 0);
6369 mpz_set_si (result
->value
.integer
, 1);
6376 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
6381 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6384 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6389 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6390 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6391 return range_check (result
, "OR");
6394 return gfc_get_logical_expr (kind
, &x
->where
,
6395 x
->value
.logical
|| y
->value
.logical
);
6403 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
6406 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
6408 if (!is_constant_array_expr (array
)
6409 || !is_constant_array_expr (vector
)
6410 || (!gfc_is_constant_expr (mask
)
6411 && !is_constant_array_expr (mask
)))
6414 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
6415 if (array
->ts
.type
== BT_DERIVED
)
6416 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
6418 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
6419 vector_ctor
= vector
6420 ? gfc_constructor_first (vector
->value
.constructor
)
6423 if (mask
->expr_type
== EXPR_CONSTANT
6424 && mask
->value
.logical
)
6426 /* Copy all elements of ARRAY to RESULT. */
6429 gfc_constructor_append_expr (&result
->value
.constructor
,
6430 gfc_copy_expr (array_ctor
->expr
),
6433 array_ctor
= gfc_constructor_next (array_ctor
);
6434 vector_ctor
= gfc_constructor_next (vector_ctor
);
6437 else if (mask
->expr_type
== EXPR_ARRAY
)
6439 /* Copy only those elements of ARRAY to RESULT whose
6440 MASK equals .TRUE.. */
6441 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6444 if (mask_ctor
->expr
->value
.logical
)
6446 gfc_constructor_append_expr (&result
->value
.constructor
,
6447 gfc_copy_expr (array_ctor
->expr
),
6449 vector_ctor
= gfc_constructor_next (vector_ctor
);
6452 array_ctor
= gfc_constructor_next (array_ctor
);
6453 mask_ctor
= gfc_constructor_next (mask_ctor
);
6457 /* Append any left-over elements from VECTOR to RESULT. */
6460 gfc_constructor_append_expr (&result
->value
.constructor
,
6461 gfc_copy_expr (vector_ctor
->expr
),
6463 vector_ctor
= gfc_constructor_next (vector_ctor
);
6466 result
->shape
= gfc_get_shape (1);
6467 gfc_array_size (result
, &result
->shape
[0]);
6469 if (array
->ts
.type
== BT_CHARACTER
)
6470 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
6477 do_xor (gfc_expr
*result
, gfc_expr
*e
)
6479 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
6480 gcc_assert (result
->ts
.type
== BT_LOGICAL
6481 && result
->expr_type
== EXPR_CONSTANT
);
6483 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
6489 gfc_simplify_is_contiguous (gfc_expr
*array
)
6491 if (gfc_is_simply_contiguous (array
, false, true))
6492 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 1);
6494 if (gfc_is_not_contiguous (array
))
6495 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 0);
6502 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
6504 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
6509 gfc_simplify_popcnt (gfc_expr
*e
)
6514 if (e
->expr_type
!= EXPR_CONSTANT
)
6517 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6519 /* Convert argument to unsigned, then count the '1' bits. */
6520 mpz_init_set (x
, e
->value
.integer
);
6521 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
6522 res
= mpz_popcount (x
);
6525 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
6530 gfc_simplify_poppar (gfc_expr
*e
)
6535 if (e
->expr_type
!= EXPR_CONSTANT
)
6538 popcnt
= gfc_simplify_popcnt (e
);
6539 gcc_assert (popcnt
);
6541 bool fail
= gfc_extract_int (popcnt
, &i
);
6544 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
6549 gfc_simplify_precision (gfc_expr
*e
)
6551 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6552 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
6553 gfc_real_kinds
[i
].precision
);
6558 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6560 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
6565 gfc_simplify_radix (gfc_expr
*e
)
6568 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6573 i
= gfc_integer_kinds
[i
].radix
;
6577 i
= gfc_real_kinds
[i
].radix
;
6584 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6589 gfc_simplify_range (gfc_expr
*e
)
6592 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6597 i
= gfc_integer_kinds
[i
].range
;
6602 i
= gfc_real_kinds
[i
].range
;
6609 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6614 gfc_simplify_rank (gfc_expr
*e
)
6620 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
6625 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
6627 gfc_expr
*result
= NULL
;
6628 int kind
, tmp1
, tmp2
;
6630 /* Convert BOZ to real, and return without range checking. */
6631 if (e
->ts
.type
== BT_BOZ
)
6633 /* Determine kind for conversion of the BOZ. */
6635 gfc_extract_int (k
, &kind
);
6637 kind
= gfc_default_real_kind
;
6639 if (!gfc_boz2real (e
, kind
))
6641 result
= gfc_copy_expr (e
);
6645 if (e
->ts
.type
== BT_COMPLEX
)
6646 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
6648 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
6651 return &gfc_bad_expr
;
6653 if (e
->expr_type
!= EXPR_CONSTANT
)
6656 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
6658 tmp1
= warn_conversion
;
6659 tmp2
= warn_conversion_extra
;
6660 warn_conversion
= warn_conversion_extra
= 0;
6662 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
6664 warn_conversion
= tmp1
;
6665 warn_conversion_extra
= tmp2
;
6667 if (result
== &gfc_bad_expr
)
6668 return &gfc_bad_expr
;
6670 return range_check (result
, "REAL");
6675 gfc_simplify_realpart (gfc_expr
*e
)
6679 if (e
->expr_type
!= EXPR_CONSTANT
)
6682 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6683 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
6685 return range_check (result
, "REALPART");
6689 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
6694 bool have_length
= false;
6696 /* If NCOPIES isn't a constant, there's nothing we can do. */
6697 if (n
->expr_type
!= EXPR_CONSTANT
)
6700 /* If NCOPIES is negative, it's an error. */
6701 if (mpz_sgn (n
->value
.integer
) < 0)
6703 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6705 return &gfc_bad_expr
;
6708 /* If we don't know the character length, we can do no more. */
6709 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
6710 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6712 len
= gfc_mpz_get_hwi (e
->ts
.u
.cl
->length
->value
.integer
);
6715 else if (e
->expr_type
== EXPR_CONSTANT
6716 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
6718 len
= e
->value
.character
.length
;
6723 /* If the source length is 0, any value of NCOPIES is valid
6724 and everything behaves as if NCOPIES == 0. */
6727 mpz_set_ui (ncopies
, 0);
6729 mpz_set (ncopies
, n
->value
.integer
);
6731 /* Check that NCOPIES isn't too large. */
6737 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6739 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6743 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
6744 e
->ts
.u
.cl
->length
->value
.integer
);
6749 gfc_mpz_set_hwi (mlen
, len
);
6750 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
6754 /* The check itself. */
6755 if (mpz_cmp (ncopies
, max
) > 0)
6758 mpz_clear (ncopies
);
6759 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6761 return &gfc_bad_expr
;
6766 mpz_clear (ncopies
);
6768 /* For further simplification, we need the character string to be
6770 if (e
->expr_type
!= EXPR_CONSTANT
)
6775 (e
->ts
.u
.cl
->length
&&
6776 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
) != 0))
6778 bool fail
= gfc_extract_hwi (n
, &ncop
);
6785 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
6787 len
= e
->value
.character
.length
;
6788 gfc_charlen_t nlen
= ncop
* len
;
6790 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6791 (2**28 elements * 4 bytes (wide chars) per element) defer to
6792 runtime instead of consuming (unbounded) memory and CPU at
6794 if (nlen
> 268435456)
6796 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6797 " deferred to runtime, expect bugs", &e
->where
);
6801 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
6802 for (size_t i
= 0; i
< (size_t) ncop
; i
++)
6803 for (size_t j
= 0; j
< (size_t) len
; j
++)
6804 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
6806 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
6811 /* This one is a bear, but mainly has to do with shuffling elements. */
6814 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
6815 gfc_expr
*pad
, gfc_expr
*order_exp
)
6817 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
6818 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
6822 gfc_expr
*e
, *result
;
6823 bool zerosize
= false;
6825 /* Check that argument expression types are OK. */
6826 if (!is_constant_array_expr (source
)
6827 || !is_constant_array_expr (shape_exp
)
6828 || !is_constant_array_expr (pad
)
6829 || !is_constant_array_expr (order_exp
))
6832 if (source
->shape
== NULL
)
6835 /* Proceed with simplification, unpacking the array. */
6840 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
6845 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
6849 gfc_extract_int (e
, &shape
[rank
]);
6851 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
6852 if (shape
[rank
] < 0)
6854 gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
6855 "negative value %d for dimension %d",
6856 &shape_exp
->where
, shape
[rank
], rank
+1);
6857 return &gfc_bad_expr
;
6863 gcc_assert (rank
> 0);
6865 /* Now unpack the order array if present. */
6866 if (order_exp
== NULL
)
6868 for (i
= 0; i
< rank
; i
++)
6874 int order_size
, shape_size
;
6876 if (order_exp
->rank
!= shape_exp
->rank
)
6878 gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
6879 &order_exp
->where
, &shape_exp
->where
);
6880 return &gfc_bad_expr
;
6883 gfc_array_size (shape_exp
, &size
);
6884 shape_size
= mpz_get_ui (size
);
6886 gfc_array_size (order_exp
, &size
);
6887 order_size
= mpz_get_ui (size
);
6889 if (order_size
!= shape_size
)
6891 gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
6892 &order_exp
->where
, &shape_exp
->where
);
6893 return &gfc_bad_expr
;
6896 for (i
= 0; i
< rank
; i
++)
6898 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
6901 gfc_extract_int (e
, &order
[i
]);
6903 if (order
[i
] < 1 || order
[i
] > rank
)
6905 gfc_error ("Element with a value of %d in ORDER at %L must be "
6906 "in the range [1, ..., %d] for the RESHAPE intrinsic "
6907 "near %L", order
[i
], &order_exp
->where
, rank
,
6909 return &gfc_bad_expr
;
6913 if (x
[order
[i
]] != 0)
6915 gfc_error ("ORDER at %L is not a permutation of the size of "
6916 "SHAPE at %L", &order_exp
->where
, &shape_exp
->where
);
6917 return &gfc_bad_expr
;
6923 /* Count the elements in the source and padding arrays. */
6928 gfc_array_size (pad
, &size
);
6929 npad
= mpz_get_ui (size
);
6933 gfc_array_size (source
, &size
);
6934 nsource
= mpz_get_ui (size
);
6937 /* If it weren't for that pesky permutation we could just loop
6938 through the source and round out any shortage with pad elements.
6939 But no, someone just had to have the compiler do something the
6940 user should be doing. */
6942 for (i
= 0; i
< rank
; i
++)
6945 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6947 if (source
->ts
.type
== BT_DERIVED
)
6948 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6949 if (source
->ts
.type
== BT_CHARACTER
&& result
->ts
.u
.cl
== NULL
)
6950 result
->ts
= source
->ts
;
6951 result
->rank
= rank
;
6952 result
->shape
= gfc_get_shape (rank
);
6953 for (i
= 0; i
< rank
; i
++)
6955 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
6963 while (nsource
> 0 || npad
> 0)
6965 /* Figure out which element to extract. */
6966 mpz_set_ui (index
, 0);
6968 for (i
= rank
- 1; i
>= 0; i
--)
6970 mpz_add_ui (index
, index
, x
[order
[i
]]);
6972 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
6975 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
6976 gfc_internal_error ("Reshaped array too large at %C");
6978 j
= mpz_get_ui (index
);
6981 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
6991 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
6995 gfc_constructor_append_expr (&result
->value
.constructor
,
6996 gfc_copy_expr (e
), &e
->where
);
6998 /* Calculate the next element. */
7002 if (++x
[i
] < shape
[i
])
7020 gfc_simplify_rrspacing (gfc_expr
*x
)
7026 if (x
->expr_type
!= EXPR_CONSTANT
)
7029 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7031 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7033 /* RRSPACING(+/- 0.0) = 0.0 */
7034 if (mpfr_zero_p (x
->value
.real
))
7036 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7040 /* RRSPACING(inf) = NaN */
7041 if (mpfr_inf_p (x
->value
.real
))
7043 mpfr_set_nan (result
->value
.real
);
7047 /* RRSPACING(NaN) = same NaN */
7048 if (mpfr_nan_p (x
->value
.real
))
7050 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7054 /* | x * 2**(-e) | * 2**p. */
7055 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7056 e
= - (long int) mpfr_get_exp (x
->value
.real
);
7057 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
7059 p
= (long int) gfc_real_kinds
[i
].digits
;
7060 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
7062 return range_check (result
, "RRSPACING");
7067 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
7069 int k
, neg_flag
, power
, exp_range
;
7070 mpfr_t scale
, radix
;
7073 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7076 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7078 if (mpfr_zero_p (x
->value
.real
))
7080 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7084 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
7086 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
7088 /* This check filters out values of i that would overflow an int. */
7089 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
7090 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
7092 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
7093 gfc_free_expr (result
);
7094 return &gfc_bad_expr
;
7097 /* Compute scale = radix ** power. */
7098 power
= mpz_get_si (i
->value
.integer
);
7108 gfc_set_model_kind (x
->ts
.kind
);
7111 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
7112 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
7115 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7117 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7119 mpfr_clears (scale
, radix
, NULL
);
7121 return range_check (result
, "SCALE");
7125 /* Variants of strspn and strcspn that operate on wide characters. */
7128 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7131 const gfc_char_t
*c
;
7135 for (c
= s2
; *c
; c
++)
7149 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7152 const gfc_char_t
*c
;
7156 for (c
= s2
; *c
; c
++)
7171 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
7176 size_t indx
, len
, lenc
;
7177 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
7180 return &gfc_bad_expr
;
7182 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
7183 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
7186 if (b
!= NULL
&& b
->value
.logical
!= 0)
7191 len
= e
->value
.character
.length
;
7192 lenc
= c
->value
.character
.length
;
7194 if (len
== 0 || lenc
== 0)
7202 indx
= wide_strcspn (e
->value
.character
.string
,
7203 c
->value
.character
.string
) + 1;
7208 for (indx
= len
; indx
> 0; indx
--)
7210 for (i
= 0; i
< lenc
; i
++)
7212 if (c
->value
.character
.string
[i
]
7213 == e
->value
.character
.string
[indx
- 1])
7221 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
7222 return range_check (result
, "SCAN");
7227 gfc_simplify_selected_char_kind (gfc_expr
*e
)
7231 if (e
->expr_type
!= EXPR_CONSTANT
)
7234 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
7235 || gfc_compare_with_Cstring (e
, "default", false) == 0)
7237 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
7242 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7247 gfc_simplify_selected_int_kind (gfc_expr
*e
)
7251 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
))
7256 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
7257 if (gfc_integer_kinds
[i
].range
>= range
7258 && gfc_integer_kinds
[i
].kind
< kind
)
7259 kind
= gfc_integer_kinds
[i
].kind
;
7261 if (kind
== INT_MAX
)
7264 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7269 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
7271 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
7273 locus
*loc
= &gfc_current_locus
;
7279 if (p
->expr_type
!= EXPR_CONSTANT
7280 || gfc_extract_int (p
, &precision
))
7289 if (q
->expr_type
!= EXPR_CONSTANT
7290 || gfc_extract_int (q
, &range
))
7301 if (rdx
->expr_type
!= EXPR_CONSTANT
7302 || gfc_extract_int (rdx
, &radix
))
7310 found_precision
= 0;
7314 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
7316 if (gfc_real_kinds
[i
].precision
>= precision
)
7317 found_precision
= 1;
7319 if (gfc_real_kinds
[i
].range
>= range
)
7322 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7325 if (gfc_real_kinds
[i
].precision
>= precision
7326 && gfc_real_kinds
[i
].range
>= range
7327 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7328 && gfc_real_kinds
[i
].kind
< kind
)
7329 kind
= gfc_real_kinds
[i
].kind
;
7332 if (kind
== INT_MAX
)
7334 if (found_radix
&& found_range
&& !found_precision
)
7336 else if (found_radix
&& found_precision
&& !found_range
)
7338 else if (found_radix
&& !found_precision
&& !found_range
)
7340 else if (found_radix
)
7346 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
7351 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
7354 mpfr_t exp
, absv
, log2
, pow2
, frac
;
7357 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7360 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7362 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7363 SET_EXPONENT (NaN) = same NaN */
7364 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
7366 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7370 /* SET_EXPONENT (inf) = NaN */
7371 if (mpfr_inf_p (x
->value
.real
))
7373 mpfr_set_nan (result
->value
.real
);
7377 gfc_set_model_kind (x
->ts
.kind
);
7384 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
7385 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
7387 mpfr_trunc (log2
, log2
);
7388 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
7390 /* Old exponent value, and fraction. */
7391 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
7393 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
7396 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
7397 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
7399 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
7401 return range_check (result
, "SET_EXPONENT");
7406 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
7408 mpz_t shape
[GFC_MAX_DIMENSIONS
];
7409 gfc_expr
*result
, *e
, *f
;
7413 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
7415 if (source
->rank
== -1)
7418 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
7419 result
->shape
= gfc_get_shape (1);
7420 mpz_init (result
->shape
[0]);
7422 if (source
->rank
== 0)
7425 if (source
->expr_type
== EXPR_VARIABLE
)
7427 ar
= gfc_find_array_ref (source
);
7428 t
= gfc_array_ref_shape (ar
, shape
);
7430 else if (source
->shape
)
7433 for (n
= 0; n
< source
->rank
; n
++)
7435 mpz_init (shape
[n
]);
7436 mpz_set (shape
[n
], source
->shape
[n
]);
7442 for (n
= 0; n
< source
->rank
; n
++)
7444 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
7447 mpz_set (e
->value
.integer
, shape
[n
]);
7450 mpz_set_ui (e
->value
.integer
, n
+ 1);
7452 f
= simplify_size (source
, e
, k
);
7456 gfc_free_expr (result
);
7463 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
7465 gfc_free_expr (result
);
7467 gfc_clear_shape (shape
, source
->rank
);
7468 return &gfc_bad_expr
;
7471 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
7475 gfc_clear_shape (shape
, source
->rank
);
7477 mpz_set_si (result
->shape
[0], source
->rank
);
7484 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
7487 gfc_expr
*return_value
;
7491 /* For unary operations, the size of the result is given by the size
7492 of the operand. For binary ones, it's the size of the first operand
7493 unless it is scalar, then it is the size of the second. */
7494 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
7496 gfc_expr
* replacement
;
7497 gfc_expr
* simplified
;
7499 switch (array
->value
.op
.op
)
7501 /* Unary operations. */
7503 case INTRINSIC_UPLUS
:
7504 case INTRINSIC_UMINUS
:
7505 case INTRINSIC_PARENTHESES
:
7506 replacement
= array
->value
.op
.op1
;
7509 /* Binary operations. If any one of the operands is scalar, take
7510 the other one's size. If both of them are arrays, it does not
7511 matter -- try to find one with known shape, if possible. */
7513 if (array
->value
.op
.op1
->rank
== 0)
7514 replacement
= array
->value
.op
.op2
;
7515 else if (array
->value
.op
.op2
->rank
== 0)
7516 replacement
= array
->value
.op
.op1
;
7519 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
7523 replacement
= array
->value
.op
.op2
;
7528 /* Try to reduce it directly if possible. */
7529 simplified
= simplify_size (replacement
, dim
, k
);
7531 /* Otherwise, we build a new SIZE call. This is hopefully at least
7532 simpler than the original one. */
7535 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
7536 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
7537 GFC_ISYM_SIZE
, "size",
7539 gfc_copy_expr (replacement
),
7540 gfc_copy_expr (dim
),
7546 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
7547 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
)
7548 gfc_resolve_array_spec (ref
->u
.ar
.as
, 0);
7552 if (!gfc_array_size (array
, &size
))
7557 if (dim
->expr_type
!= EXPR_CONSTANT
)
7560 d
= mpz_get_ui (dim
->value
.integer
) - 1;
7561 if (!gfc_array_dimen_size (array
, d
, &size
))
7565 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
7566 mpz_set (return_value
->value
.integer
, size
);
7569 return return_value
;
7574 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
7577 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
7580 return &gfc_bad_expr
;
7582 result
= simplify_size (array
, dim
, k
);
7583 if (result
== NULL
|| result
== &gfc_bad_expr
)
7586 return range_check (result
, "SIZE");
7590 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
7591 multiplied by the array size. */
7594 gfc_simplify_sizeof (gfc_expr
*x
)
7596 gfc_expr
*result
= NULL
;
7600 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7603 if (x
->ts
.type
== BT_CHARACTER
7604 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7605 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7608 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
7609 && !gfc_array_size (x
, &array_size
))
7612 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
7614 gfc_target_expr_size (x
, &res_size
);
7615 mpz_set_si (result
->value
.integer
, res_size
);
7621 /* STORAGE_SIZE returns the size in bits of a single array element. */
7624 gfc_simplify_storage_size (gfc_expr
*x
,
7627 gfc_expr
*result
= NULL
;
7631 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7634 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
7635 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7636 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7639 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
7641 return &gfc_bad_expr
;
7643 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
7645 gfc_element_size (x
, &siz
);
7646 mpz_set_si (result
->value
.integer
, siz
);
7647 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
7649 return range_check (result
, "STORAGE_SIZE");
7654 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
7658 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
7661 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7666 mpz_abs (result
->value
.integer
, x
->value
.integer
);
7667 if (mpz_sgn (y
->value
.integer
) < 0)
7668 mpz_neg (result
->value
.integer
, result
->value
.integer
);
7673 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
7676 mpfr_setsign (result
->value
.real
, x
->value
.real
,
7677 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
7681 gfc_internal_error ("Bad type in gfc_simplify_sign");
7689 gfc_simplify_sin (gfc_expr
*x
)
7693 if (x
->expr_type
!= EXPR_CONSTANT
)
7696 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7701 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7705 gfc_set_model (x
->value
.real
);
7706 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7710 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
7713 return range_check (result
, "SIN");
7718 gfc_simplify_sinh (gfc_expr
*x
)
7722 if (x
->expr_type
!= EXPR_CONSTANT
)
7725 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7730 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7734 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7741 return range_check (result
, "SINH");
7745 /* The argument is always a double precision real that is converted to
7746 single precision. TODO: Rounding! */
7749 gfc_simplify_sngl (gfc_expr
*a
)
7754 if (a
->expr_type
!= EXPR_CONSTANT
)
7757 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
7759 tmp1
= warn_conversion
;
7760 tmp2
= warn_conversion_extra
;
7761 warn_conversion
= warn_conversion_extra
= 0;
7763 result
= gfc_real2real (a
, gfc_default_real_kind
);
7765 warn_conversion
= tmp1
;
7766 warn_conversion_extra
= tmp2
;
7768 return range_check (result
, "SNGL");
7773 gfc_simplify_spacing (gfc_expr
*x
)
7779 if (x
->expr_type
!= EXPR_CONSTANT
)
7782 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7783 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7785 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
7786 if (mpfr_zero_p (x
->value
.real
))
7788 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
7792 /* SPACING(inf) = NaN */
7793 if (mpfr_inf_p (x
->value
.real
))
7795 mpfr_set_nan (result
->value
.real
);
7799 /* SPACING(NaN) = same NaN */
7800 if (mpfr_nan_p (x
->value
.real
))
7802 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7806 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
7807 are the radix, exponent of x, and precision. This excludes the
7808 possibility of subnormal numbers. Fortran 2003 states the result is
7809 b**max(e - p, emin - 1). */
7811 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
7812 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
7813 en
= en
> ep
? en
: ep
;
7815 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
7816 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
7818 return range_check (result
, "SPACING");
7823 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
7825 gfc_expr
*result
= NULL
;
7826 int nelem
, i
, j
, dim
, ncopies
;
7829 if ((!gfc_is_constant_expr (source
)
7830 && !is_constant_array_expr (source
))
7831 || !gfc_is_constant_expr (dim_expr
)
7832 || !gfc_is_constant_expr (ncopies_expr
))
7835 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
7836 gfc_extract_int (dim_expr
, &dim
);
7837 dim
-= 1; /* zero-base DIM */
7839 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
7840 gfc_extract_int (ncopies_expr
, &ncopies
);
7841 ncopies
= MAX (ncopies
, 0);
7843 /* Do not allow the array size to exceed the limit for an array
7845 if (source
->expr_type
== EXPR_ARRAY
)
7847 if (!gfc_array_size (source
, &size
))
7848 gfc_internal_error ("Failure getting length of a constant array.");
7851 mpz_init_set_ui (size
, 1);
7853 nelem
= mpz_get_si (size
) * ncopies
;
7854 if (nelem
> flag_max_array_constructor
)
7856 if (gfc_init_expr_flag
)
7858 gfc_error ("The number of elements (%d) in the array constructor "
7859 "at %L requires an increase of the allowed %d upper "
7860 "limit. See %<-fmax-array-constructor%> option.",
7861 nelem
, &source
->where
, flag_max_array_constructor
);
7862 return &gfc_bad_expr
;
7868 if (source
->expr_type
== EXPR_CONSTANT
7869 || source
->expr_type
== EXPR_STRUCTURE
)
7871 gcc_assert (dim
== 0);
7873 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7875 if (source
->ts
.type
== BT_DERIVED
)
7876 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7878 result
->shape
= gfc_get_shape (result
->rank
);
7879 mpz_init_set_si (result
->shape
[0], ncopies
);
7881 for (i
= 0; i
< ncopies
; ++i
)
7882 gfc_constructor_append_expr (&result
->value
.constructor
,
7883 gfc_copy_expr (source
), NULL
);
7885 else if (source
->expr_type
== EXPR_ARRAY
)
7887 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
7888 gfc_constructor
*source_ctor
;
7890 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
7891 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
7893 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7895 if (source
->ts
.type
== BT_DERIVED
)
7896 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7897 result
->rank
= source
->rank
+ 1;
7898 result
->shape
= gfc_get_shape (result
->rank
);
7900 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
7903 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
7905 mpz_init_set_si (result
->shape
[i
], ncopies
);
7907 extent
[i
] = mpz_get_si (result
->shape
[i
]);
7908 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
7912 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
7913 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
7915 for (i
= 0; i
< ncopies
; ++i
)
7916 gfc_constructor_insert_expr (&result
->value
.constructor
,
7917 gfc_copy_expr (source_ctor
->expr
),
7918 NULL
, offset
+ i
* rstride
[dim
]);
7920 offset
+= (dim
== 0 ? ncopies
: 1);
7925 gfc_error ("Simplification of SPREAD at %C not yet implemented");
7926 return &gfc_bad_expr
;
7929 if (source
->ts
.type
== BT_CHARACTER
)
7930 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
7937 gfc_simplify_sqrt (gfc_expr
*e
)
7939 gfc_expr
*result
= NULL
;
7941 if (e
->expr_type
!= EXPR_CONSTANT
)
7947 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
7949 gfc_error ("Argument of SQRT at %L has a negative value",
7951 return &gfc_bad_expr
;
7953 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7954 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
7958 gfc_set_model (e
->value
.real
);
7960 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7961 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
7965 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
7968 return range_check (result
, "SQRT");
7973 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
7975 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
7979 /* Simplify COTAN(X) where X has the unit of radian. */
7982 gfc_simplify_cotan (gfc_expr
*x
)
7987 if (x
->expr_type
!= EXPR_CONSTANT
)
7990 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7995 mpfr_cot (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7999 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
8000 val
= &result
->value
.complex;
8001 mpc_init2 (swp
, mpfr_get_default_prec ());
8002 mpc_sin_cos (*val
, swp
, x
->value
.complex, GFC_MPC_RND_MODE
,
8004 mpc_div (*val
, swp
, *val
, GFC_MPC_RND_MODE
);
8012 return range_check (result
, "COTAN");
8017 gfc_simplify_tan (gfc_expr
*x
)
8021 if (x
->expr_type
!= EXPR_CONSTANT
)
8024 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8029 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8033 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8040 return range_check (result
, "TAN");
8045 gfc_simplify_tanh (gfc_expr
*x
)
8049 if (x
->expr_type
!= EXPR_CONSTANT
)
8052 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8057 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8061 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8068 return range_check (result
, "TANH");
8073 gfc_simplify_tiny (gfc_expr
*e
)
8078 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
8080 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
8081 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
8088 gfc_simplify_trailz (gfc_expr
*e
)
8090 unsigned long tz
, bs
;
8093 if (e
->expr_type
!= EXPR_CONSTANT
)
8096 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
8097 bs
= gfc_integer_kinds
[i
].bit_size
;
8098 tz
= mpz_scan1 (e
->value
.integer
, 0);
8100 return gfc_get_int_expr (gfc_default_integer_kind
,
8101 &e
->where
, MIN (tz
, bs
));
8106 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
8109 gfc_expr
*mold_element
;
8114 unsigned char *buffer
;
8115 size_t result_length
;
8117 if (!gfc_is_constant_expr (source
) || !gfc_is_constant_expr (size
))
8120 if (!gfc_resolve_expr (mold
))
8122 if (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
8125 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
8126 &result_size
, &result_length
))
8129 /* Calculate the size of the source. */
8130 if (source
->expr_type
== EXPR_ARRAY
&& !gfc_array_size (source
, &tmp
))
8131 gfc_internal_error ("Failure getting length of a constant array.");
8133 /* Create an empty new expression with the appropriate characteristics. */
8134 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
8136 result
->ts
= mold
->ts
;
8138 mold_element
= (mold
->expr_type
== EXPR_ARRAY
&& mold
->value
.constructor
)
8139 ? gfc_constructor_first (mold
->value
.constructor
)->expr
8142 /* Set result character length, if needed. Note that this needs to be
8143 set even for array expressions, in order to pass this information into
8144 gfc_target_interpret_expr. */
8145 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
8146 result
->value
.character
.length
= mold_element
->value
.character
.length
;
8148 /* Set the number of elements in the result, and determine its size. */
8150 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
8152 result
->expr_type
= EXPR_ARRAY
;
8154 result
->shape
= gfc_get_shape (1);
8155 mpz_init_set_ui (result
->shape
[0], result_length
);
8160 /* Allocate the buffer to store the binary version of the source. */
8161 buffer_size
= MAX (source_size
, result_size
);
8162 buffer
= (unsigned char*)alloca (buffer_size
);
8163 memset (buffer
, 0, buffer_size
);
8165 /* Now write source to the buffer. */
8166 gfc_target_encode_expr (source
, buffer
, buffer_size
);
8168 /* And read the buffer back into the new expression. */
8169 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
8176 gfc_simplify_transpose (gfc_expr
*matrix
)
8178 int row
, matrix_rows
, col
, matrix_cols
;
8181 if (!is_constant_array_expr (matrix
))
8184 gcc_assert (matrix
->rank
== 2);
8186 if (matrix
->shape
== NULL
)
8189 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
8192 result
->shape
= gfc_get_shape (result
->rank
);
8193 mpz_init_set (result
->shape
[0], matrix
->shape
[1]);
8194 mpz_init_set (result
->shape
[1], matrix
->shape
[0]);
8196 if (matrix
->ts
.type
== BT_CHARACTER
)
8197 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
8198 else if (matrix
->ts
.type
== BT_DERIVED
)
8199 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
8201 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
8202 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
8203 for (row
= 0; row
< matrix_rows
; ++row
)
8204 for (col
= 0; col
< matrix_cols
; ++col
)
8206 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
8207 col
* matrix_rows
+ row
);
8208 gfc_constructor_insert_expr (&result
->value
.constructor
,
8209 gfc_copy_expr (e
), &matrix
->where
,
8210 row
* matrix_cols
+ col
);
8218 gfc_simplify_trim (gfc_expr
*e
)
8221 int count
, i
, len
, lentrim
;
8223 if (e
->expr_type
!= EXPR_CONSTANT
)
8226 len
= e
->value
.character
.length
;
8227 for (count
= 0, i
= 1; i
<= len
; ++i
)
8229 if (e
->value
.character
.string
[len
- i
] == ' ')
8235 lentrim
= len
- count
;
8237 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
8238 for (i
= 0; i
< lentrim
; i
++)
8239 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
8246 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
8251 gfc_constructor
*sub_cons
;
8255 if (!is_constant_array_expr (sub
))
8258 /* Follow any component references. */
8259 as
= coarray
->symtree
->n
.sym
->as
;
8260 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
8261 if (ref
->type
== REF_COMPONENT
)
8264 if (as
->type
== AS_DEFERRED
)
8267 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
8268 the cosubscript addresses the first image. */
8270 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
8273 for (d
= 1; d
<= as
->corank
; d
++)
8278 gcc_assert (sub_cons
!= NULL
);
8280 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
8282 if (ca_bound
== NULL
)
8285 if (ca_bound
== &gfc_bad_expr
)
8288 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
8292 gfc_free_expr (ca_bound
);
8293 sub_cons
= gfc_constructor_next (sub_cons
);
8297 first_image
= false;
8301 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8302 "SUB has %ld and COARRAY lower bound is %ld)",
8304 mpz_get_si (sub_cons
->expr
->value
.integer
),
8305 mpz_get_si (ca_bound
->value
.integer
));
8306 gfc_free_expr (ca_bound
);
8307 return &gfc_bad_expr
;
8310 gfc_free_expr (ca_bound
);
8312 /* Check whether upperbound is valid for the multi-images case. */
8315 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
8317 if (ca_bound
== &gfc_bad_expr
)
8320 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
8321 && mpz_cmp (ca_bound
->value
.integer
,
8322 sub_cons
->expr
->value
.integer
) < 0)
8324 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8325 "SUB has %ld and COARRAY upper bound is %ld)",
8327 mpz_get_si (sub_cons
->expr
->value
.integer
),
8328 mpz_get_si (ca_bound
->value
.integer
));
8329 gfc_free_expr (ca_bound
);
8330 return &gfc_bad_expr
;
8334 gfc_free_expr (ca_bound
);
8337 sub_cons
= gfc_constructor_next (sub_cons
);
8340 gcc_assert (sub_cons
== NULL
);
8342 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
8345 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8346 &gfc_current_locus
);
8348 mpz_set_si (result
->value
.integer
, 1);
8350 mpz_set_si (result
->value
.integer
, 0);
8356 gfc_simplify_image_status (gfc_expr
*image
, gfc_expr
*team ATTRIBUTE_UNUSED
)
8358 if (flag_coarray
== GFC_FCOARRAY_NONE
)
8360 gfc_current_locus
= *gfc_current_intrinsic_where
;
8361 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
8362 return &gfc_bad_expr
;
8365 /* Simplification is possible for fcoarray = single only. For all other modes
8366 the result depends on runtime conditions. */
8367 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8370 if (gfc_is_constant_expr (image
))
8373 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8375 if (mpz_get_si (image
->value
.integer
) == 1)
8376 mpz_set_si (result
->value
.integer
, 0);
8378 mpz_set_si (result
->value
.integer
, GFC_STAT_STOPPED_IMAGE
);
8387 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
8388 gfc_expr
*distance ATTRIBUTE_UNUSED
)
8390 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8393 /* If no coarray argument has been passed or when the first argument
8394 is actually a distance argment. */
8395 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
8398 /* FIXME: gfc_current_locus is wrong. */
8399 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8400 &gfc_current_locus
);
8401 mpz_set_si (result
->value
.integer
, 1);
8405 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
8406 return simplify_cobound (coarray
, dim
, NULL
, 0);
8411 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8413 return simplify_bound (array
, dim
, kind
, 1);
8417 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8419 return simplify_cobound (array
, dim
, kind
, 1);
8424 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
8426 gfc_expr
*result
, *e
;
8427 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
8429 if (!is_constant_array_expr (vector
)
8430 || !is_constant_array_expr (mask
)
8431 || (!gfc_is_constant_expr (field
)
8432 && !is_constant_array_expr (field
)))
8435 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
8437 if (vector
->ts
.type
== BT_DERIVED
)
8438 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
8439 result
->rank
= mask
->rank
;
8440 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
8442 if (vector
->ts
.type
== BT_CHARACTER
)
8443 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
8445 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
8446 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
8448 = field
->expr_type
== EXPR_ARRAY
8449 ? gfc_constructor_first (field
->value
.constructor
)
8454 if (mask_ctor
->expr
->value
.logical
)
8456 gcc_assert (vector_ctor
);
8457 e
= gfc_copy_expr (vector_ctor
->expr
);
8458 vector_ctor
= gfc_constructor_next (vector_ctor
);
8460 else if (field
->expr_type
== EXPR_ARRAY
)
8461 e
= gfc_copy_expr (field_ctor
->expr
);
8463 e
= gfc_copy_expr (field
);
8465 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
8467 mask_ctor
= gfc_constructor_next (mask_ctor
);
8468 field_ctor
= gfc_constructor_next (field_ctor
);
8476 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
8480 size_t index
, len
, lenset
;
8482 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
8485 return &gfc_bad_expr
;
8487 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
8488 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
8491 if (b
!= NULL
&& b
->value
.logical
!= 0)
8496 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
8498 len
= s
->value
.character
.length
;
8499 lenset
= set
->value
.character
.length
;
8503 mpz_set_ui (result
->value
.integer
, 0);
8511 mpz_set_ui (result
->value
.integer
, 1);
8515 index
= wide_strspn (s
->value
.character
.string
,
8516 set
->value
.character
.string
) + 1;
8525 mpz_set_ui (result
->value
.integer
, len
);
8528 for (index
= len
; index
> 0; index
--)
8530 for (i
= 0; i
< lenset
; i
++)
8532 if (s
->value
.character
.string
[index
- 1]
8533 == set
->value
.character
.string
[i
])
8541 mpz_set_ui (result
->value
.integer
, index
);
8547 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
8552 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
8555 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
8560 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
8561 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
8562 return range_check (result
, "XOR");
8565 return gfc_get_logical_expr (kind
, &x
->where
,
8566 (x
->value
.logical
&& !y
->value
.logical
)
8567 || (!x
->value
.logical
&& y
->value
.logical
));
8575 /****************** Constant simplification *****************/
8577 /* Master function to convert one constant to another. While this is
8578 used as a simplification function, it requires the destination type
8579 and kind information which is supplied by a special case in
8583 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
8585 gfc_expr
*result
, *(*f
) (gfc_expr
*, int);
8586 gfc_constructor
*c
, *t
;
8600 f
= gfc_int2complex
;
8620 f
= gfc_real2complex
;
8631 f
= gfc_complex2int
;
8634 f
= gfc_complex2real
;
8637 f
= gfc_complex2complex
;
8663 f
= gfc_hollerith2int
;
8667 f
= gfc_hollerith2real
;
8671 f
= gfc_hollerith2complex
;
8675 f
= gfc_hollerith2character
;
8679 f
= gfc_hollerith2logical
;
8691 f
= gfc_character2int
;
8695 f
= gfc_character2real
;
8699 f
= gfc_character2complex
;
8703 f
= gfc_character2character
;
8707 f
= gfc_character2logical
;
8717 return &gfc_bad_expr
;
8722 switch (e
->expr_type
)
8725 result
= f (e
, kind
);
8727 return &gfc_bad_expr
;
8731 if (!gfc_is_constant_expr (e
))
8734 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8735 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8736 result
->rank
= e
->rank
;
8738 for (c
= gfc_constructor_first (e
->value
.constructor
);
8739 c
; c
= gfc_constructor_next (c
))
8742 if (c
->iterator
== NULL
)
8744 if (c
->expr
->expr_type
== EXPR_ARRAY
)
8745 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8746 else if (c
->expr
->expr_type
== EXPR_OP
)
8748 if (!gfc_simplify_expr (c
->expr
, 1))
8749 return &gfc_bad_expr
;
8750 tmp
= f (c
->expr
, kind
);
8753 tmp
= f (c
->expr
, kind
);
8756 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8758 if (tmp
== NULL
|| tmp
== &gfc_bad_expr
)
8760 gfc_free_expr (result
);
8764 t
= gfc_constructor_append_expr (&result
->value
.constructor
,
8767 t
->iterator
= gfc_copy_iterator (c
->iterator
);
8780 /* Function for converting character constants. */
8782 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
8787 if (!gfc_is_constant_expr (e
))
8790 if (e
->expr_type
== EXPR_CONSTANT
)
8792 /* Simple case of a scalar. */
8793 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
8795 return &gfc_bad_expr
;
8797 result
->value
.character
.length
= e
->value
.character
.length
;
8798 result
->value
.character
.string
8799 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
8800 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
8801 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
8803 /* Check we only have values representable in the destination kind. */
8804 for (i
= 0; i
< result
->value
.character
.length
; i
++)
8805 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
8808 gfc_error ("Character %qs in string at %L cannot be converted "
8809 "into character kind %d",
8810 gfc_print_wide_char (result
->value
.character
.string
[i
]),
8812 gfc_free_expr (result
);
8813 return &gfc_bad_expr
;
8818 else if (e
->expr_type
== EXPR_ARRAY
)
8820 /* For an array constructor, we convert each constructor element. */
8823 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8824 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8825 result
->rank
= e
->rank
;
8826 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
8828 for (c
= gfc_constructor_first (e
->value
.constructor
);
8829 c
; c
= gfc_constructor_next (c
))
8831 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
8832 if (tmp
== &gfc_bad_expr
)
8834 gfc_free_expr (result
);
8835 return &gfc_bad_expr
;
8840 gfc_free_expr (result
);
8844 gfc_constructor_append_expr (&result
->value
.constructor
,
8856 gfc_simplify_compiler_options (void)
8861 str
= gfc_get_option_string ();
8862 result
= gfc_get_character_expr (gfc_default_character_kind
,
8863 &gfc_current_locus
, str
, strlen (str
));
8870 gfc_simplify_compiler_version (void)
8875 len
= strlen ("GCC version ") + strlen (version_string
);
8876 buffer
= XALLOCAVEC (char, len
+ 1);
8877 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
8878 return gfc_get_character_expr (gfc_default_character_kind
,
8879 &gfc_current_locus
, buffer
, len
);
8882 /* Simplification routines for intrinsics of IEEE modules. */
8885 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
8887 gfc_actual_arglist
*arg
;
8888 gfc_expr
*p
= NULL
, *q
= NULL
, *rdx
= NULL
;
8890 arg
= expr
->value
.function
.actual
;
8894 q
= arg
->next
->expr
;
8895 if (arg
->next
->next
)
8896 rdx
= arg
->next
->next
->expr
;
8899 /* Currently, if IEEE is supported and this module is built, it means
8900 all our floating-point types conform to IEEE. Hence, we simply handle
8901 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
8902 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
8906 simplify_ieee_support (gfc_expr
*expr
)
8908 /* We consider that if the IEEE modules are loaded, we have full support
8909 for flags, halting and rounding, which are the three functions
8910 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
8911 expressions. One day, we will need libgfortran to detect support and
8912 communicate it back to us, allowing for partial support. */
8914 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
8919 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
8921 int n
= strlen(name
);
8923 if (!strncmp(sym
->name
, name
, n
))
8926 /* If a generic was used and renamed, we need more work to find out.
8927 Compare the specific name. */
8928 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
8935 gfc_simplify_ieee_functions (gfc_expr
*expr
)
8937 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
8939 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
8940 return simplify_ieee_selected_real_kind (expr
);
8941 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
8942 || matches_ieee_function_name(sym
, "ieee_support_halting")
8943 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
8944 return simplify_ieee_support (expr
);