1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2024 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 /* A non-zero-sized constant array shall have a non-empty constructor. */
237 if (e
->rank
> 0 && e
->shape
!= NULL
&& e
->value
.constructor
== NULL
)
239 mpz_init_set_ui (size
, 1);
240 for (int j
= 0; j
< e
->rank
; j
++)
241 mpz_mul (size
, size
, e
->shape
[j
]);
242 bool not_size0
= (mpz_cmp_si (size
, 0) != 0);
248 for (c
= gfc_constructor_first (e
->value
.constructor
);
249 c
; c
= gfc_constructor_next (c
))
250 if (c
->expr
->expr_type
!= EXPR_CONSTANT
251 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
257 /* Check and expand the constructor. We do this when either
258 gfc_init_expr_flag is set or for not too large array constructors. */
260 expand
= (e
->rank
== 1
262 && (mpz_cmp_ui (e
->shape
[0], flag_max_array_constructor
) < 0));
264 if (!array_OK
&& (gfc_init_expr_flag
|| expand
) && e
->rank
== 1)
266 bool saved_init_expr_flag
= gfc_init_expr_flag
;
267 array_OK
= gfc_reduce_init_expr (e
);
268 /* gfc_reduce_init_expr resets the flag. */
269 gfc_init_expr_flag
= saved_init_expr_flag
;
274 /* Recheck to make sure that any EXPR_ARRAYs have gone. */
275 for (c
= gfc_constructor_first (e
->value
.constructor
);
276 c
; c
= gfc_constructor_next (c
))
277 if (c
->expr
->expr_type
!= EXPR_CONSTANT
278 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
281 /* Make sure that the array has a valid shape. */
282 if (e
->shape
== NULL
&& e
->rank
== 1)
284 if (!gfc_array_size(e
, &size
))
286 e
->shape
= gfc_get_shape (1);
287 mpz_init_set (e
->shape
[0], size
);
295 gfc_is_constant_array_expr (gfc_expr
*e
)
297 return is_constant_array_expr (e
);
301 /* Test for a size zero array. */
303 gfc_is_size_zero_array (gfc_expr
*array
)
306 if (array
->rank
== 0)
309 if (array
->expr_type
== EXPR_VARIABLE
&& array
->rank
> 0
310 && array
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
311 && array
->shape
!= NULL
)
313 for (int i
= 0; i
< array
->rank
; i
++)
314 if (mpz_cmp_si (array
->shape
[i
], 0) <= 0)
320 if (array
->expr_type
== EXPR_ARRAY
)
321 return array
->value
.constructor
== NULL
;
327 /* Initialize a transformational result expression with a given value. */
330 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
332 if (e
&& e
->expr_type
== EXPR_ARRAY
)
334 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
337 init_result_expr (ctor
->expr
, init
, array
);
338 ctor
= gfc_constructor_next (ctor
);
341 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
343 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
344 HOST_WIDE_INT length
;
350 e
->value
.logical
= (init
? 1 : 0);
355 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
356 else if (init
== INT_MAX
)
357 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
359 mpz_set_si (e
->value
.integer
, init
);
365 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
366 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
368 else if (init
== INT_MAX
)
369 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
371 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
375 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
381 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
382 gfc_extract_hwi (len
, &length
);
383 string
= gfc_get_wide_string (length
+ 1);
384 gfc_wide_memset (string
, 0, length
);
386 else if (init
== INT_MAX
)
388 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
389 gfc_extract_hwi (len
, &length
);
390 string
= gfc_get_wide_string (length
+ 1);
391 gfc_wide_memset (string
, 255, length
);
396 string
= gfc_get_wide_string (1);
399 string
[length
] = '\0';
400 e
->value
.character
.length
= length
;
401 e
->value
.character
.string
= string
;
413 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
414 if conj_a is true, the matrix_a is complex conjugated. */
417 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
418 gfc_expr
*matrix_b
, int stride_b
, int offset_b
,
421 gfc_expr
*result
, *a
, *b
, *c
;
423 /* Set result to an INTEGER(1) 0 for numeric types and .false. for
424 LOGICAL. Mixed-mode math in the loop will promote result to the
425 correct type and kind. */
426 if (matrix_a
->ts
.type
== BT_LOGICAL
)
427 result
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, false);
429 result
= gfc_get_int_expr (1, NULL
, 0);
430 result
->where
= matrix_a
->where
;
432 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
433 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
436 /* Copying of expressions is required as operands are free'd
437 by the gfc_arith routines. */
438 switch (result
->ts
.type
)
441 result
= gfc_or (result
,
442 gfc_and (gfc_copy_expr (a
),
449 if (conj_a
&& a
->ts
.type
== BT_COMPLEX
)
450 c
= gfc_simplify_conjg (a
);
452 c
= gfc_copy_expr (a
);
453 result
= gfc_add (result
, gfc_multiply (c
, gfc_copy_expr (b
)));
460 offset_a
+= stride_a
;
461 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
463 offset_b
+= stride_b
;
464 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
471 /* Build a result expression for transformational intrinsics,
475 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
476 int kind
, locus
* where
)
481 if (!dim
|| array
->rank
== 1)
482 return gfc_get_constant_expr (type
, kind
, where
);
484 result
= gfc_get_array_expr (type
, kind
, where
);
485 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
486 result
->rank
= array
->rank
- 1;
488 /* gfc_array_size() would count the number of elements in the constructor,
489 we have not built those yet. */
491 for (i
= 0; i
< result
->rank
; ++i
)
492 nelem
*= mpz_get_ui (result
->shape
[i
]);
494 for (i
= 0; i
< nelem
; ++i
)
496 gfc_constructor_append_expr (&result
->value
.constructor
,
497 gfc_get_constant_expr (type
, kind
, where
),
505 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
507 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
508 of COUNT intrinsic is .TRUE..
510 Interface and implementation mimics arith functions as
511 gfc_add, gfc_multiply, etc. */
514 gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
518 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
519 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
520 gcc_assert (op2
->value
.logical
);
522 result
= gfc_copy_expr (op1
);
523 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
531 /* Transforms an ARRAY with operation OP, according to MASK, to a
532 scalar RESULT. E.g. called if
534 REAL, PARAMETER :: array(n, m) = ...
535 REAL, PARAMETER :: s = SUM(array)
537 where OP == gfc_add(). */
540 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
541 transformational_op op
)
544 gfc_constructor
*array_ctor
, *mask_ctor
;
546 /* Shortcut for constant .FALSE. MASK. */
548 && mask
->expr_type
== EXPR_CONSTANT
549 && !mask
->value
.logical
)
552 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
554 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
555 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
559 a
= array_ctor
->expr
;
560 array_ctor
= gfc_constructor_next (array_ctor
);
562 /* A constant MASK equals .TRUE. here and can be ignored. */
566 mask_ctor
= gfc_constructor_next (mask_ctor
);
567 if (!m
->value
.logical
)
571 result
= op (result
, gfc_copy_expr (a
));
579 /* Transforms an ARRAY with operation OP, according to MASK, to an
580 array RESULT. E.g. called if
582 REAL, PARAMETER :: array(n, m) = ...
583 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
585 where OP == gfc_multiply().
586 The result might be post processed using post_op. */
589 simplify_transformation_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*dim
,
590 gfc_expr
*mask
, transformational_op op
,
591 transformational_op post_op
)
594 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
595 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
596 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
598 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
599 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
600 tmpstride
[GFC_MAX_DIMENSIONS
];
602 /* Shortcut for constant .FALSE. MASK. */
604 && mask
->expr_type
== EXPR_CONSTANT
605 && !mask
->value
.logical
)
608 /* Build an indexed table for array element expressions to minimize
609 linked-list traversal. Masked elements are set to NULL. */
610 gfc_array_size (array
, &size
);
611 arraysize
= mpz_get_ui (size
);
614 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
616 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
618 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
619 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
621 for (i
= 0; i
< arraysize
; ++i
)
623 arrayvec
[i
] = array_ctor
->expr
;
624 array_ctor
= gfc_constructor_next (array_ctor
);
628 if (!mask_ctor
->expr
->value
.logical
)
631 mask_ctor
= gfc_constructor_next (mask_ctor
);
635 /* Same for the result expression. */
636 gfc_array_size (result
, &size
);
637 resultsize
= mpz_get_ui (size
);
640 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
641 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
642 for (i
= 0; i
< resultsize
; ++i
)
644 resultvec
[i
] = result_ctor
->expr
;
645 result_ctor
= gfc_constructor_next (result_ctor
);
648 gfc_extract_int (dim
, &dim_index
);
649 dim_index
-= 1; /* zero-base index */
653 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
656 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
659 dim_extent
= mpz_get_si (array
->shape
[i
]);
660 dim_stride
= tmpstride
[i
];
664 extent
[n
] = mpz_get_si (array
->shape
[i
]);
665 sstride
[n
] = tmpstride
[i
];
666 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
670 done
= resultsize
<= 0;
675 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
677 *dest
= op (*dest
, gfc_copy_expr (*src
));
680 *dest
= post_op (*dest
, *dest
);
687 while (!done
&& count
[n
] == extent
[n
])
690 base
-= sstride
[n
] * extent
[n
];
691 dest
-= dstride
[n
] * extent
[n
];
694 if (n
< result
->rank
)
696 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
697 times, we'd warn for the last iteration, because the
698 array index will have already been incremented to the
699 array sizes, and we can't tell that this must make
700 the test against result->rank false, because ranks
701 must not exceed GFC_MAX_DIMENSIONS. */
702 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
713 /* Place updated expression in result constructor. */
714 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
715 for (i
= 0; i
< resultsize
; ++i
)
717 result_ctor
->expr
= resultvec
[i
];
718 result_ctor
= gfc_constructor_next (result_ctor
);
728 simplify_transformation (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
729 int init_val
, transformational_op op
)
734 size_zero
= gfc_is_size_zero_array (array
);
736 if (!(is_constant_array_expr (array
) || size_zero
)
737 || array
->shape
== NULL
738 || !gfc_is_constant_expr (dim
))
742 && !is_constant_array_expr (mask
)
743 && mask
->expr_type
!= EXPR_CONSTANT
)
746 result
= transformational_result (array
, dim
, array
->ts
.type
,
747 array
->ts
.kind
, &array
->where
);
748 init_result_expr (result
, init_val
, array
);
753 return !dim
|| array
->rank
== 1 ?
754 simplify_transformation_to_scalar (result
, array
, mask
, op
) :
755 simplify_transformation_to_array (result
, array
, dim
, mask
, op
, NULL
);
759 /********************** Simplification functions *****************************/
762 gfc_simplify_abs (gfc_expr
*e
)
766 if (e
->expr_type
!= EXPR_CONSTANT
)
772 result
= gfc_get_constant_expr (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
773 mpz_abs (result
->value
.integer
, e
->value
.integer
);
774 return range_check (result
, "IABS");
777 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
778 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
779 return range_check (result
, "ABS");
782 gfc_set_model_kind (e
->ts
.kind
);
783 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
784 mpc_abs (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
785 return range_check (result
, "CABS");
788 gfc_internal_error ("gfc_simplify_abs(): Bad type");
794 simplify_achar_char (gfc_expr
*e
, gfc_expr
*k
, const char *name
, bool ascii
)
798 bool too_large
= false;
800 if (e
->expr_type
!= EXPR_CONSTANT
)
803 kind
= get_kind (BT_CHARACTER
, k
, name
, gfc_default_character_kind
);
805 return &gfc_bad_expr
;
807 if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
809 gfc_error ("Argument of %s function at %L is negative", name
,
811 return &gfc_bad_expr
;
814 if (ascii
&& warn_surprising
&& mpz_cmp_si (e
->value
.integer
, 127) > 0)
815 gfc_warning (OPT_Wsurprising
,
816 "Argument of %s function at %L outside of range [0,127]",
819 if (kind
== 1 && mpz_cmp_si (e
->value
.integer
, 255) > 0)
824 mpz_init_set_ui (t
, 2);
825 mpz_pow_ui (t
, t
, 32);
826 mpz_sub_ui (t
, t
, 1);
827 if (mpz_cmp (e
->value
.integer
, t
) > 0)
834 gfc_error ("Argument of %s function at %L is too large for the "
835 "collating sequence of kind %d", name
, &e
->where
, kind
);
836 return &gfc_bad_expr
;
839 result
= gfc_get_character_expr (kind
, &e
->where
, NULL
, 1);
840 result
->value
.character
.string
[0] = mpz_get_ui (e
->value
.integer
);
847 /* We use the processor's collating sequence, because all
848 systems that gfortran currently works on are ASCII. */
851 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
853 return simplify_achar_char (e
, k
, "ACHAR", true);
858 gfc_simplify_acos (gfc_expr
*x
)
862 if (x
->expr_type
!= EXPR_CONSTANT
)
868 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
869 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
871 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
873 return &gfc_bad_expr
;
875 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
876 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
880 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
881 mpc_acos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
885 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
888 return range_check (result
, "ACOS");
892 gfc_simplify_acosh (gfc_expr
*x
)
896 if (x
->expr_type
!= EXPR_CONSTANT
)
902 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
904 gfc_error ("Argument of ACOSH at %L must not be less than 1",
906 return &gfc_bad_expr
;
909 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
910 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
914 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
915 mpc_acosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
919 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
922 return range_check (result
, "ACOSH");
926 gfc_simplify_adjustl (gfc_expr
*e
)
932 if (e
->expr_type
!= EXPR_CONSTANT
)
935 len
= e
->value
.character
.length
;
937 for (count
= 0, i
= 0; i
< len
; ++i
)
939 ch
= e
->value
.character
.string
[i
];
945 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
946 for (i
= 0; i
< len
- count
; ++i
)
947 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
954 gfc_simplify_adjustr (gfc_expr
*e
)
960 if (e
->expr_type
!= EXPR_CONSTANT
)
963 len
= e
->value
.character
.length
;
965 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
967 ch
= e
->value
.character
.string
[i
];
973 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
974 for (i
= 0; i
< count
; ++i
)
975 result
->value
.character
.string
[i
] = ' ';
977 for (i
= count
; i
< len
; ++i
)
978 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
985 gfc_simplify_aimag (gfc_expr
*e
)
989 if (e
->expr_type
!= EXPR_CONSTANT
)
992 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
993 mpfr_set (result
->value
.real
, mpc_imagref (e
->value
.complex), GFC_RND_MODE
);
995 return range_check (result
, "AIMAG");
1000 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
1002 gfc_expr
*rtrunc
, *result
;
1005 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
1007 return &gfc_bad_expr
;
1009 if (e
->expr_type
!= EXPR_CONSTANT
)
1012 rtrunc
= gfc_copy_expr (e
);
1013 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1015 result
= gfc_real2real (rtrunc
, kind
);
1017 gfc_free_expr (rtrunc
);
1019 return range_check (result
, "AINT");
1024 gfc_simplify_all (gfc_expr
*mask
, gfc_expr
*dim
)
1026 return simplify_transformation (mask
, dim
, NULL
, true, gfc_and
);
1031 gfc_simplify_dint (gfc_expr
*e
)
1033 gfc_expr
*rtrunc
, *result
;
1035 if (e
->expr_type
!= EXPR_CONSTANT
)
1038 rtrunc
= gfc_copy_expr (e
);
1039 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1041 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
1043 gfc_free_expr (rtrunc
);
1045 return range_check (result
, "DINT");
1050 gfc_simplify_dreal (gfc_expr
*e
)
1052 gfc_expr
*result
= NULL
;
1054 if (e
->expr_type
!= EXPR_CONSTANT
)
1057 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
1058 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
1060 return range_check (result
, "DREAL");
1065 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
1070 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
1072 return &gfc_bad_expr
;
1074 if (e
->expr_type
!= EXPR_CONSTANT
)
1077 result
= gfc_get_constant_expr (e
->ts
.type
, kind
, &e
->where
);
1078 mpfr_round (result
->value
.real
, e
->value
.real
);
1080 return range_check (result
, "ANINT");
1085 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
1090 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1093 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1098 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
1099 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1100 return range_check (result
, "AND");
1103 return gfc_get_logical_expr (kind
, &x
->where
,
1104 x
->value
.logical
&& y
->value
.logical
);
1113 gfc_simplify_any (gfc_expr
*mask
, gfc_expr
*dim
)
1115 return simplify_transformation (mask
, dim
, NULL
, false, gfc_or
);
1120 gfc_simplify_dnint (gfc_expr
*e
)
1124 if (e
->expr_type
!= EXPR_CONSTANT
)
1127 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &e
->where
);
1128 mpfr_round (result
->value
.real
, e
->value
.real
);
1130 return range_check (result
, "DNINT");
1135 gfc_simplify_asin (gfc_expr
*x
)
1139 if (x
->expr_type
!= EXPR_CONSTANT
)
1145 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1146 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1148 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1150 return &gfc_bad_expr
;
1152 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1153 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1157 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1158 mpc_asin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1162 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1165 return range_check (result
, "ASIN");
1169 /* Convert radians to degrees, i.e., x * 180 / pi. */
1177 mpfr_const_pi (tmp
, GFC_RND_MODE
);
1178 mpfr_mul_ui (x
, x
, 180, GFC_RND_MODE
);
1179 mpfr_div (x
, x
, tmp
, GFC_RND_MODE
);
1184 /* Simplify ACOSD(X) where the returned value has units of degree. */
1187 gfc_simplify_acosd (gfc_expr
*x
)
1191 if (x
->expr_type
!= EXPR_CONSTANT
)
1194 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1195 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1197 gfc_error ("Argument of ACOSD at %L must be between -1 and 1",
1199 return &gfc_bad_expr
;
1202 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1203 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1204 rad2deg (result
->value
.real
);
1206 return range_check (result
, "ACOSD");
1210 /* Simplify asind (x) where the returned value has units of degree. */
1213 gfc_simplify_asind (gfc_expr
*x
)
1217 if (x
->expr_type
!= EXPR_CONSTANT
)
1220 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1221 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1223 gfc_error ("Argument of ASIND at %L must be between -1 and 1",
1225 return &gfc_bad_expr
;
1228 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1229 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1230 rad2deg (result
->value
.real
);
1232 return range_check (result
, "ASIND");
1236 /* Simplify atand (x) where the returned value has units of degree. */
1239 gfc_simplify_atand (gfc_expr
*x
)
1243 if (x
->expr_type
!= EXPR_CONSTANT
)
1246 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1247 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1248 rad2deg (result
->value
.real
);
1250 return range_check (result
, "ATAND");
1255 gfc_simplify_asinh (gfc_expr
*x
)
1259 if (x
->expr_type
!= EXPR_CONSTANT
)
1262 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1267 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1271 mpc_asinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1275 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1278 return range_check (result
, "ASINH");
1283 gfc_simplify_atan (gfc_expr
*x
)
1287 if (x
->expr_type
!= EXPR_CONSTANT
)
1290 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1295 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1299 mpc_atan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1303 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1306 return range_check (result
, "ATAN");
1311 gfc_simplify_atanh (gfc_expr
*x
)
1315 if (x
->expr_type
!= EXPR_CONSTANT
)
1321 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
1322 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
1324 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1326 return &gfc_bad_expr
;
1328 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1329 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1333 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1334 mpc_atanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1338 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1341 return range_check (result
, "ATANH");
1346 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1350 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1353 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1355 gfc_error ("If first argument of ATAN2 at %L is zero, then the "
1356 "second argument must not be zero", &y
->where
);
1357 return &gfc_bad_expr
;
1360 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1361 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1363 return range_check (result
, "ATAN2");
1368 gfc_simplify_bessel_j0 (gfc_expr
*x
)
1372 if (x
->expr_type
!= EXPR_CONSTANT
)
1375 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1376 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1378 return range_check (result
, "BESSEL_J0");
1383 gfc_simplify_bessel_j1 (gfc_expr
*x
)
1387 if (x
->expr_type
!= EXPR_CONSTANT
)
1390 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1391 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1393 return range_check (result
, "BESSEL_J1");
1398 gfc_simplify_bessel_jn (gfc_expr
*order
, gfc_expr
*x
)
1403 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1406 n
= mpz_get_si (order
->value
.integer
);
1407 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1408 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1410 return range_check (result
, "BESSEL_JN");
1414 /* Simplify transformational form of JN and YN. */
1417 gfc_simplify_bessel_n2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
,
1424 mpfr_t x2rev
, last1
, last2
;
1426 if (x
->expr_type
!= EXPR_CONSTANT
|| order1
->expr_type
!= EXPR_CONSTANT
1427 || order2
->expr_type
!= EXPR_CONSTANT
)
1430 n1
= mpz_get_si (order1
->value
.integer
);
1431 n2
= mpz_get_si (order2
->value
.integer
);
1432 result
= gfc_get_array_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1434 result
->shape
= gfc_get_shape (1);
1435 mpz_init_set_ui (result
->shape
[0], MAX (n2
-n1
+1, 0));
1440 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1441 YN(N, 0.0) = -Inf. */
1443 if (mpfr_cmp_ui (x
->value
.real
, 0.0) == 0)
1445 if (!jn
&& flag_range_check
)
1447 gfc_error ("Result of BESSEL_YN is -INF at %L", &result
->where
);
1448 gfc_free_expr (result
);
1449 return &gfc_bad_expr
;
1454 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1455 mpfr_set_ui (e
->value
.real
, 1, GFC_RND_MODE
);
1456 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1461 for (i
= n1
; i
<= n2
; i
++)
1463 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1465 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
1467 mpfr_set_inf (e
->value
.real
, -1);
1468 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1475 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1476 are stable for downward recursion and Neumann functions are stable
1477 for upward recursion. It is
1479 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1480 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1481 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1483 gfc_set_model_kind (x
->ts
.kind
);
1485 /* Get first recursion anchor. */
1489 mpfr_jn (last1
, n2
, x
->value
.real
, GFC_RND_MODE
);
1491 mpfr_yn (last1
, n1
, x
->value
.real
, GFC_RND_MODE
);
1493 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1494 mpfr_set (e
->value
.real
, last1
, GFC_RND_MODE
);
1495 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1499 gfc_free_expr (result
);
1500 return &gfc_bad_expr
;
1502 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1510 /* Get second recursion anchor. */
1514 mpfr_jn (last2
, n2
-1, x
->value
.real
, GFC_RND_MODE
);
1516 mpfr_yn (last2
, n1
+1, x
->value
.real
, GFC_RND_MODE
);
1518 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1519 mpfr_set (e
->value
.real
, last2
, GFC_RND_MODE
);
1520 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1525 gfc_free_expr (result
);
1526 return &gfc_bad_expr
;
1529 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
, -2);
1531 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1540 /* Start actual recursion. */
1543 mpfr_ui_div (x2rev
, 2, x
->value
.real
, GFC_RND_MODE
);
1545 for (i
= 2; i
<= n2
-n1
; i
++)
1547 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1549 /* Special case: For YN, if the previous N gave -INF, set
1550 also N+1 to -INF. */
1551 if (!jn
&& !flag_range_check
&& mpfr_inf_p (last2
))
1553 mpfr_set_inf (e
->value
.real
, -1);
1554 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1559 mpfr_mul_si (e
->value
.real
, x2rev
, jn
? (n2
-i
+1) : (n1
+i
-1),
1561 mpfr_mul (e
->value
.real
, e
->value
.real
, last2
, GFC_RND_MODE
);
1562 mpfr_sub (e
->value
.real
, e
->value
.real
, last1
, GFC_RND_MODE
);
1564 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1566 /* Range_check frees "e" in that case. */
1572 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
,
1575 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1577 mpfr_set (last1
, last2
, GFC_RND_MODE
);
1578 mpfr_set (last2
, e
->value
.real
, GFC_RND_MODE
);
1591 gfc_free_expr (result
);
1592 return &gfc_bad_expr
;
1597 gfc_simplify_bessel_jn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1599 return gfc_simplify_bessel_n2 (order1
, order2
, x
, true);
1604 gfc_simplify_bessel_y0 (gfc_expr
*x
)
1608 if (x
->expr_type
!= EXPR_CONSTANT
)
1611 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1612 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1614 return range_check (result
, "BESSEL_Y0");
1619 gfc_simplify_bessel_y1 (gfc_expr
*x
)
1623 if (x
->expr_type
!= EXPR_CONSTANT
)
1626 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1627 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1629 return range_check (result
, "BESSEL_Y1");
1634 gfc_simplify_bessel_yn (gfc_expr
*order
, gfc_expr
*x
)
1639 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1642 n
= mpz_get_si (order
->value
.integer
);
1643 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1644 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1646 return range_check (result
, "BESSEL_YN");
1651 gfc_simplify_bessel_yn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1653 return gfc_simplify_bessel_n2 (order1
, order2
, x
, false);
1658 gfc_simplify_bit_size (gfc_expr
*e
)
1660 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1661 return gfc_get_int_expr (e
->ts
.kind
, &e
->where
,
1662 gfc_integer_kinds
[i
].bit_size
);
1667 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
1671 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
1674 if (!gfc_check_bitfcn (e
, bit
))
1675 return &gfc_bad_expr
;
1677 if (gfc_extract_int (bit
, &b
) || b
< 0)
1678 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
, false);
1680 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
,
1681 mpz_tstbit (e
->value
.integer
, b
));
1686 compare_bitwise (gfc_expr
*i
, gfc_expr
*j
)
1691 gcc_assert (i
->ts
.type
== BT_INTEGER
);
1692 gcc_assert (j
->ts
.type
== BT_INTEGER
);
1694 mpz_init_set (x
, i
->value
.integer
);
1695 k
= gfc_validate_kind (i
->ts
.type
, i
->ts
.kind
, false);
1696 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
1698 mpz_init_set (y
, j
->value
.integer
);
1699 k
= gfc_validate_kind (j
->ts
.type
, j
->ts
.kind
, false);
1700 convert_mpz_to_unsigned (y
, gfc_integer_kinds
[k
].bit_size
);
1702 res
= mpz_cmp (x
, y
);
1710 gfc_simplify_bge (gfc_expr
*i
, gfc_expr
*j
)
1712 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1715 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1716 compare_bitwise (i
, j
) >= 0);
1721 gfc_simplify_bgt (gfc_expr
*i
, gfc_expr
*j
)
1723 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1726 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1727 compare_bitwise (i
, j
) > 0);
1732 gfc_simplify_ble (gfc_expr
*i
, gfc_expr
*j
)
1734 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1737 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1738 compare_bitwise (i
, j
) <= 0);
1743 gfc_simplify_blt (gfc_expr
*i
, gfc_expr
*j
)
1745 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1748 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1749 compare_bitwise (i
, j
) < 0);
1754 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
1756 gfc_expr
*ceil
, *result
;
1759 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
1761 return &gfc_bad_expr
;
1763 if (e
->expr_type
!= EXPR_CONSTANT
)
1766 ceil
= gfc_copy_expr (e
);
1767 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
1769 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
1770 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
, &e
->where
);
1772 gfc_free_expr (ceil
);
1774 return range_check (result
, "CEILING");
1779 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
1781 return simplify_achar_char (e
, k
, "CHAR", false);
1785 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1788 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
1792 if (x
->expr_type
!= EXPR_CONSTANT
1793 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1796 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &x
->where
);
1801 mpc_set_z (result
->value
.complex, x
->value
.integer
, GFC_MPC_RND_MODE
);
1805 mpc_set_fr (result
->value
.complex, x
->value
.real
, GFC_RND_MODE
);
1809 mpc_set (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1813 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1817 return range_check (result
, name
);
1822 mpfr_set_z (mpc_imagref (result
->value
.complex),
1823 y
->value
.integer
, GFC_RND_MODE
);
1827 mpfr_set (mpc_imagref (result
->value
.complex),
1828 y
->value
.real
, GFC_RND_MODE
);
1832 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1835 return range_check (result
, name
);
1840 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
1844 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_complex_kind
);
1846 return &gfc_bad_expr
;
1848 return simplify_cmplx ("CMPLX", x
, y
, kind
);
1853 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
1857 if (x
->ts
.type
== BT_INTEGER
&& y
->ts
.type
== BT_INTEGER
)
1858 kind
= gfc_default_complex_kind
;
1859 else if (x
->ts
.type
== BT_REAL
|| y
->ts
.type
== BT_INTEGER
)
1861 else if (x
->ts
.type
== BT_INTEGER
|| y
->ts
.type
== BT_REAL
)
1863 else if (x
->ts
.type
== BT_REAL
&& y
->ts
.type
== BT_REAL
)
1864 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
1868 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1873 gfc_simplify_conjg (gfc_expr
*e
)
1877 if (e
->expr_type
!= EXPR_CONSTANT
)
1880 result
= gfc_copy_expr (e
);
1881 mpc_conj (result
->value
.complex, result
->value
.complex, GFC_MPC_RND_MODE
);
1883 return range_check (result
, "CONJG");
1887 /* Simplify atan2d (x) where the unit is degree. */
1890 gfc_simplify_atan2d (gfc_expr
*y
, gfc_expr
*x
)
1894 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1897 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1899 gfc_error ("If first argument of ATAN2D at %L is zero, then the "
1900 "second argument must not be zero", &y
->where
);
1901 return &gfc_bad_expr
;
1904 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1905 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1906 rad2deg (result
->value
.real
);
1908 return range_check (result
, "ATAN2D");
1913 gfc_simplify_cos (gfc_expr
*x
)
1917 if (x
->expr_type
!= EXPR_CONSTANT
)
1920 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1925 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1929 gfc_set_model_kind (x
->ts
.kind
);
1930 mpc_cos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1934 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1937 return range_check (result
, "COS");
1947 mpfr_const_pi (d2r
, GFC_RND_MODE
);
1948 mpfr_div_ui (d2r
, d2r
, 180, GFC_RND_MODE
);
1949 mpfr_mul (x
, x
, d2r
, GFC_RND_MODE
);
1954 /* Simplification routines for SIND, COSD, TAND. */
1955 #include "trigd_fe.inc"
1958 /* Simplify COSD(X) where X has the unit of degree. */
1961 gfc_simplify_cosd (gfc_expr
*x
)
1965 if (x
->expr_type
!= EXPR_CONSTANT
)
1968 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1969 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1970 simplify_cosd (result
->value
.real
);
1972 return range_check (result
, "COSD");
1976 /* Simplify SIND(X) where X has the unit of degree. */
1979 gfc_simplify_sind (gfc_expr
*x
)
1983 if (x
->expr_type
!= EXPR_CONSTANT
)
1986 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1987 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1988 simplify_sind (result
->value
.real
);
1990 return range_check (result
, "SIND");
1994 /* Simplify TAND(X) where X has the unit of degree. */
1997 gfc_simplify_tand (gfc_expr
*x
)
2001 if (x
->expr_type
!= EXPR_CONSTANT
)
2004 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2005 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2006 simplify_tand (result
->value
.real
);
2008 return range_check (result
, "TAND");
2012 /* Simplify COTAND(X) where X has the unit of degree. */
2015 gfc_simplify_cotand (gfc_expr
*x
)
2019 if (x
->expr_type
!= EXPR_CONSTANT
)
2022 /* Implement COTAND = -TAND(x+90).
2023 TAND offers correct exact values for multiples of 30 degrees.
2024 This implementation is also compatible with the behavior of some legacy
2025 compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */
2026 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2027 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2028 mpfr_add_ui (result
->value
.real
, result
->value
.real
, 90, GFC_RND_MODE
);
2029 simplify_tand (result
->value
.real
);
2030 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
2032 return range_check (result
, "COTAND");
2037 gfc_simplify_cosh (gfc_expr
*x
)
2041 if (x
->expr_type
!= EXPR_CONSTANT
)
2044 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2049 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2053 mpc_cosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2060 return range_check (result
, "COSH");
2065 gfc_simplify_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
2070 size_zero
= gfc_is_size_zero_array (mask
);
2072 if (!(is_constant_array_expr (mask
) || size_zero
)
2073 || !gfc_is_constant_expr (dim
)
2074 || !gfc_is_constant_expr (kind
))
2077 result
= transformational_result (mask
, dim
,
2079 get_kind (BT_INTEGER
, kind
, "COUNT",
2080 gfc_default_integer_kind
),
2083 init_result_expr (result
, 0, NULL
);
2088 /* Passing MASK twice, once as data array, once as mask.
2089 Whenever gfc_count is called, '1' is added to the result. */
2090 return !dim
|| mask
->rank
== 1 ?
2091 simplify_transformation_to_scalar (result
, mask
, mask
, gfc_count
) :
2092 simplify_transformation_to_array (result
, mask
, dim
, mask
, gfc_count
, NULL
);
2095 /* Simplification routine for cshift. This works by copying the array
2096 expressions into a one-dimensional array, shuffling the values into another
2097 one-dimensional array and creating the new array expression from this. The
2098 shuffling part is basically taken from the library routine. */
2101 gfc_simplify_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
2105 gfc_expr
**arrayvec
, **resultvec
;
2106 gfc_expr
**rptr
, **sptr
;
2108 size_t arraysize
, shiftsize
, i
;
2109 gfc_constructor
*array_ctor
, *shift_ctor
;
2110 ssize_t
*shiftvec
, *hptr
;
2111 ssize_t shift_val
, len
;
2112 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
2113 hs_ex
[GFC_MAX_DIMENSIONS
+ 1],
2114 hstride
[GFC_MAX_DIMENSIONS
], sstride
[GFC_MAX_DIMENSIONS
],
2115 a_extent
[GFC_MAX_DIMENSIONS
], a_stride
[GFC_MAX_DIMENSIONS
],
2116 h_extent
[GFC_MAX_DIMENSIONS
],
2117 ss_ex
[GFC_MAX_DIMENSIONS
+ 1];
2121 gfc_expr
**src
, **dest
;
2123 if (!is_constant_array_expr (array
))
2126 if (shift
->rank
> 0)
2127 gfc_simplify_expr (shift
, 1);
2129 if (!gfc_is_constant_expr (shift
))
2132 /* Make dim zero-based. */
2135 if (!gfc_is_constant_expr (dim
))
2137 which
= mpz_get_si (dim
->value
.integer
) - 1;
2142 if (array
->shape
== NULL
)
2145 gfc_array_size (array
, &size
);
2146 arraysize
= mpz_get_ui (size
);
2149 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
2150 result
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
2151 result
->rank
= array
->rank
;
2152 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
2157 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2158 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
2159 for (i
= 0; i
< arraysize
; i
++)
2161 arrayvec
[i
] = array_ctor
->expr
;
2162 array_ctor
= gfc_constructor_next (array_ctor
);
2165 resultvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2171 for (d
=0; d
< array
->rank
; d
++)
2173 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2174 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2177 if (shift
->rank
> 0)
2179 gfc_array_size (shift
, &size
);
2180 shiftsize
= mpz_get_ui (size
);
2182 shiftvec
= XCNEWVEC (ssize_t
, shiftsize
);
2183 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2184 for (d
= 0; d
< shift
->rank
; d
++)
2186 h_extent
[d
] = mpz_get_si (shift
->shape
[d
]);
2187 hstride
[d
] = d
== 0 ? 1 : hstride
[d
-1] * h_extent
[d
-1];
2193 /* Shut up compiler */
2198 for (d
=0; d
< array
->rank
; d
++)
2202 rsoffset
= a_stride
[d
];
2208 extent
[n
] = a_extent
[d
];
2209 sstride
[n
] = a_stride
[d
];
2210 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2212 hs_ex
[n
] = hstride
[n
] * extent
[n
];
2221 for (i
= 0; i
< shiftsize
; i
++)
2224 val
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2229 shift_ctor
= gfc_constructor_next (shift_ctor
);
2235 shift_val
= mpz_get_si (shift
->value
.integer
);
2236 shift_val
= shift_val
% len
;
2241 continue_loop
= true;
2247 while (continue_loop
)
2255 src
= &sptr
[sh
* rsoffset
];
2257 for (n
= 0; n
< len
- sh
; n
++)
2264 for ( n
= 0; n
< sh
; n
++)
2276 while (count
[n
] == extent
[n
])
2286 continue_loop
= false;
2300 for (i
= 0; i
< arraysize
; i
++)
2302 gfc_constructor_append_expr (&result
->value
.constructor
,
2303 gfc_copy_expr (resultvec
[i
]),
2311 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2313 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
2318 gfc_simplify_dble (gfc_expr
*e
)
2320 gfc_expr
*result
= NULL
;
2323 if (e
->expr_type
!= EXPR_CONSTANT
)
2326 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
2328 tmp1
= warn_conversion
;
2329 tmp2
= warn_conversion_extra
;
2330 warn_conversion
= warn_conversion_extra
= 0;
2332 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
2334 warn_conversion
= tmp1
;
2335 warn_conversion_extra
= tmp2
;
2337 if (result
== &gfc_bad_expr
)
2338 return &gfc_bad_expr
;
2340 return range_check (result
, "DBLE");
2345 gfc_simplify_digits (gfc_expr
*x
)
2349 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2354 digits
= gfc_integer_kinds
[i
].digits
;
2359 digits
= gfc_real_kinds
[i
].digits
;
2366 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
2371 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
2376 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2379 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2380 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
2385 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
2386 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2388 mpz_set_ui (result
->value
.integer
, 0);
2393 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
2394 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
2397 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2402 gfc_internal_error ("gfc_simplify_dim(): Bad type");
2405 return range_check (result
, "DIM");
2410 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2412 /* If vector_a is a zero-sized array, the result is 0 for INTEGER,
2413 REAL, and COMPLEX types and .false. for LOGICAL. */
2414 if (vector_a
->shape
&& mpz_get_si (vector_a
->shape
[0]) == 0)
2416 if (vector_a
->ts
.type
== BT_LOGICAL
)
2417 return gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, false);
2419 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2422 if (!is_constant_array_expr (vector_a
)
2423 || !is_constant_array_expr (vector_b
))
2426 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
2431 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
2433 gfc_expr
*a1
, *a2
, *result
;
2435 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2438 a1
= gfc_real2real (x
, gfc_default_double_kind
);
2439 a2
= gfc_real2real (y
, gfc_default_double_kind
);
2441 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
2442 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
2447 return range_check (result
, "DPROD");
2452 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
2456 int i
, k
, size
, shift
;
2458 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
2459 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
2462 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
2463 size
= gfc_integer_kinds
[k
].bit_size
;
2465 gfc_extract_int (shiftarg
, &shift
);
2467 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2469 shift
= size
- shift
;
2471 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
2472 mpz_set_ui (result
->value
.integer
, 0);
2474 for (i
= 0; i
< shift
; i
++)
2475 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
2476 mpz_setbit (result
->value
.integer
, i
);
2478 for (i
= 0; i
< size
- shift
; i
++)
2479 if (mpz_tstbit (arg1
->value
.integer
, i
))
2480 mpz_setbit (result
->value
.integer
, shift
+ i
);
2482 /* Convert to a signed value. */
2483 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
2490 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2492 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
2497 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2499 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
2504 gfc_simplify_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2511 gfc_expr
**arrayvec
, **resultvec
;
2512 gfc_expr
**rptr
, **sptr
;
2514 size_t arraysize
, i
;
2515 gfc_constructor
*array_ctor
, *shift_ctor
, *bnd_ctor
;
2516 ssize_t shift_val
, len
;
2517 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
2518 sstride
[GFC_MAX_DIMENSIONS
], a_extent
[GFC_MAX_DIMENSIONS
],
2519 a_stride
[GFC_MAX_DIMENSIONS
], ss_ex
[GFC_MAX_DIMENSIONS
+ 1];
2523 gfc_expr
**src
, **dest
;
2526 if (!is_constant_array_expr (array
))
2529 if (shift
->rank
> 0)
2530 gfc_simplify_expr (shift
, 1);
2532 if (!gfc_is_constant_expr (shift
))
2537 if (boundary
->rank
> 0)
2538 gfc_simplify_expr (boundary
, 1);
2540 if (!gfc_is_constant_expr (boundary
))
2546 if (!gfc_is_constant_expr (dim
))
2548 which
= mpz_get_si (dim
->value
.integer
) - 1;
2554 if (boundary
== NULL
)
2556 temp_boundary
= true;
2557 switch (array
->ts
.type
)
2561 bnd
= gfc_get_int_expr (array
->ts
.kind
, NULL
, 0);
2565 bnd
= gfc_get_logical_expr (array
->ts
.kind
, NULL
, 0);
2569 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2570 mpfr_set_ui (bnd
->value
.real
, 0, GFC_RND_MODE
);
2574 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2575 mpc_set_ui (bnd
->value
.complex, 0, GFC_RND_MODE
);
2579 s_len
= mpz_get_ui (array
->ts
.u
.cl
->length
->value
.integer
);
2580 bnd
= gfc_get_character_expr (array
->ts
.kind
, &gfc_current_locus
, NULL
, s_len
);
2590 temp_boundary
= false;
2594 gfc_array_size (array
, &size
);
2595 arraysize
= mpz_get_ui (size
);
2598 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
2599 result
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
2600 result
->rank
= array
->rank
;
2601 result
->ts
= array
->ts
;
2606 if (array
->shape
== NULL
)
2609 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2610 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
2611 for (i
= 0; i
< arraysize
; i
++)
2613 arrayvec
[i
] = array_ctor
->expr
;
2614 array_ctor
= gfc_constructor_next (array_ctor
);
2617 resultvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2622 for (d
=0; d
< array
->rank
; d
++)
2624 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2625 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2628 if (shift
->rank
> 0)
2630 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2636 shift_val
= mpz_get_si (shift
->value
.integer
);
2640 bnd_ctor
= gfc_constructor_first (bnd
->value
.constructor
);
2644 /* Shut up compiler */
2649 for (d
=0; d
< array
->rank
; d
++)
2653 rsoffset
= a_stride
[d
];
2659 extent
[n
] = a_extent
[d
];
2660 sstride
[n
] = a_stride
[d
];
2661 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2667 continue_loop
= true;
2672 while (continue_loop
)
2677 sh
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2681 if (( sh
>= 0 ? sh
: -sh
) > len
)
2687 delta
= (sh
>= 0) ? sh
: -sh
;
2691 src
= &sptr
[delta
* rsoffset
];
2697 dest
= &rptr
[delta
* rsoffset
];
2700 for (n
= 0; n
< len
- delta
; n
++)
2716 *dest
= gfc_copy_expr (bnd_ctor
->expr
);
2724 *dest
= gfc_copy_expr (bnd
);
2731 shift_ctor
= gfc_constructor_next (shift_ctor
);
2734 bnd_ctor
= gfc_constructor_next (bnd_ctor
);
2738 while (count
[n
] == extent
[n
])
2746 continue_loop
= false;
2758 for (i
= 0; i
< arraysize
; i
++)
2760 gfc_constructor_append_expr (&result
->value
.constructor
,
2761 gfc_copy_expr (resultvec
[i
]),
2767 gfc_free_expr (bnd
);
2773 gfc_simplify_erf (gfc_expr
*x
)
2777 if (x
->expr_type
!= EXPR_CONSTANT
)
2780 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2781 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2783 return range_check (result
, "ERF");
2788 gfc_simplify_erfc (gfc_expr
*x
)
2792 if (x
->expr_type
!= EXPR_CONSTANT
)
2795 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2796 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2798 return range_check (result
, "ERFC");
2802 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2804 #define MAX_ITER 200
2805 #define ARG_LIMIT 12
2807 /* Calculate ERFC_SCALED directly by its definition:
2809 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2811 using a large precision for intermediate results. This is used for all
2812 but large values of the argument. */
2814 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2819 prec
= mpfr_get_default_prec ();
2820 mpfr_set_default_prec (10 * prec
);
2825 mpfr_set (a
, arg
, GFC_RND_MODE
);
2826 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2827 mpfr_exp (b
, b
, GFC_RND_MODE
);
2828 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2829 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2831 mpfr_set (res
, a
, GFC_RND_MODE
);
2832 mpfr_set_default_prec (prec
);
2838 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2840 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2841 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2844 This is used for large values of the argument. Intermediate calculations
2845 are performed with twice the precision. We don't do a fixed number of
2846 iterations of the sum, but stop when it has converged to the required
2849 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2851 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2856 prec
= mpfr_get_default_prec ();
2857 mpfr_set_default_prec (2 * prec
);
2867 mpfr_init (sumtrunc
);
2868 mpfr_set_prec (oldsum
, prec
);
2869 mpfr_set_prec (sumtrunc
, prec
);
2871 mpfr_set (x
, arg
, GFC_RND_MODE
);
2872 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2873 mpz_set_ui (num
, 1);
2875 mpfr_set (u
, x
, GFC_RND_MODE
);
2876 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2877 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2878 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2880 for (i
= 1; i
< MAX_ITER
; i
++)
2882 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2884 mpz_mul_ui (num
, num
, 2 * i
- 1);
2887 mpfr_set (w
, u
, GFC_RND_MODE
);
2888 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2890 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2891 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2893 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2895 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2896 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2900 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2902 gcc_assert (i
< MAX_ITER
);
2904 /* Divide by x * sqrt(Pi). */
2905 mpfr_const_pi (u
, GFC_RND_MODE
);
2906 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2907 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2908 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2910 mpfr_set (res
, sum
, GFC_RND_MODE
);
2911 mpfr_set_default_prec (prec
);
2913 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2919 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2923 if (x
->expr_type
!= EXPR_CONSTANT
)
2926 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2927 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2928 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2930 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2932 return range_check (result
, "ERFC_SCALED");
2940 gfc_simplify_epsilon (gfc_expr
*e
)
2945 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2947 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2948 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2950 return range_check (result
, "EPSILON");
2955 gfc_simplify_exp (gfc_expr
*x
)
2959 if (x
->expr_type
!= EXPR_CONSTANT
)
2962 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2967 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2971 gfc_set_model_kind (x
->ts
.kind
);
2972 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2976 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2979 return range_check (result
, "EXP");
2984 gfc_simplify_exponent (gfc_expr
*x
)
2989 if (x
->expr_type
!= EXPR_CONSTANT
)
2992 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2995 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2996 if (mpfr_inf_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
2998 int i
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
2999 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
3003 /* EXPONENT(+/- 0.0) = 0 */
3004 if (mpfr_zero_p (x
->value
.real
))
3006 mpz_set_ui (result
->value
.integer
, 0);
3010 gfc_set_model (x
->value
.real
);
3012 val
= (long int) mpfr_get_exp (x
->value
.real
);
3013 mpz_set_si (result
->value
.integer
, val
);
3015 return range_check (result
, "EXPONENT");
3020 gfc_simplify_failed_or_stopped_images (gfc_expr
*team ATTRIBUTE_UNUSED
,
3023 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3025 gfc_current_locus
= *gfc_current_intrinsic_where
;
3026 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3027 return &gfc_bad_expr
;
3030 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
3035 gfc_extract_int (kind
, &actual_kind
);
3037 actual_kind
= gfc_default_integer_kind
;
3039 result
= gfc_get_array_expr (BT_INTEGER
, actual_kind
, &gfc_current_locus
);
3044 /* For fcoarray = lib no simplification is possible, because it is not known
3045 what images failed or are stopped at compile time. */
3051 gfc_simplify_get_team (gfc_expr
*level ATTRIBUTE_UNUSED
)
3053 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3055 gfc_current_locus
= *gfc_current_intrinsic_where
;
3056 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3057 return &gfc_bad_expr
;
3060 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
3063 result
= gfc_get_array_expr (BT_INTEGER
, gfc_default_integer_kind
, &gfc_current_locus
);
3068 /* For fcoarray = lib no simplification is possible, because it is not known
3069 what images failed or are stopped at compile time. */
3075 gfc_simplify_float (gfc_expr
*a
)
3079 if (a
->expr_type
!= EXPR_CONSTANT
)
3082 result
= gfc_int2real (a
, gfc_default_real_kind
);
3084 return range_check (result
, "FLOAT");
3089 is_last_ref_vtab (gfc_expr
*e
)
3092 gfc_component
*comp
= NULL
;
3094 if (e
->expr_type
!= EXPR_VARIABLE
)
3097 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3098 if (ref
->type
== REF_COMPONENT
)
3099 comp
= ref
->u
.c
.component
;
3101 if (!e
->ref
|| !comp
)
3102 return e
->symtree
->n
.sym
->attr
.vtab
;
3104 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
3112 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
3114 /* Avoid simplification of resolved symbols. */
3115 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
3118 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
3119 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3120 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3123 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
3126 if ((a
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (a
).class_ok
)
3127 || (mold
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (mold
).class_ok
))
3130 /* Return .false. if the dynamic type can never be an extension. */
3131 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
3132 && !gfc_type_is_extension_of
3133 (CLASS_DATA (mold
)->ts
.u
.derived
,
3134 CLASS_DATA (a
)->ts
.u
.derived
)
3135 && !gfc_type_is_extension_of
3136 (CLASS_DATA (a
)->ts
.u
.derived
,
3137 CLASS_DATA (mold
)->ts
.u
.derived
))
3138 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
3139 && !gfc_type_is_extension_of
3140 (CLASS_DATA (mold
)->ts
.u
.derived
,
3142 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3143 && !gfc_type_is_extension_of
3144 (mold
->ts
.u
.derived
,
3145 CLASS_DATA (a
)->ts
.u
.derived
)
3146 && !gfc_type_is_extension_of
3147 (CLASS_DATA (a
)->ts
.u
.derived
,
3148 mold
->ts
.u
.derived
)))
3149 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3151 /* Return .true. if the dynamic type is guaranteed to be an extension. */
3152 if (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3153 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3154 CLASS_DATA (a
)->ts
.u
.derived
))
3155 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
3162 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3164 /* Avoid simplification of resolved symbols. */
3165 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
3168 /* Return .false. if the dynamic type can never be the
3170 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
3171 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
3172 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
3173 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
3174 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3176 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
3179 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3180 gfc_compare_derived_types (a
->ts
.u
.derived
,
3186 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
3192 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
3194 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3196 if (e
->expr_type
!= EXPR_CONSTANT
)
3199 mpfr_init2 (floor
, mpfr_get_prec (e
->value
.real
));
3200 mpfr_floor (floor
, e
->value
.real
);
3202 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
3203 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
3207 return range_check (result
, "FLOOR");
3212 gfc_simplify_fraction (gfc_expr
*x
)
3217 if (x
->expr_type
!= EXPR_CONSTANT
)
3220 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
3222 /* FRACTION(inf) = NaN. */
3223 if (mpfr_inf_p (x
->value
.real
))
3225 mpfr_set_nan (result
->value
.real
);
3229 /* mpfr_frexp() correctly handles zeros and NaNs. */
3230 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3232 return range_check (result
, "FRACTION");
3237 gfc_simplify_gamma (gfc_expr
*x
)
3241 if (x
->expr_type
!= EXPR_CONSTANT
)
3244 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3245 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3247 return range_check (result
, "GAMMA");
3252 gfc_simplify_huge (gfc_expr
*e
)
3257 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3258 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3263 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
3267 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
3279 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
3283 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3286 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3287 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
3288 return range_check (result
, "HYPOT");
3292 /* We use the processor's collating sequence, because all
3293 systems that gfortran currently works on are ASCII. */
3296 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
3302 if (e
->expr_type
!= EXPR_CONSTANT
)
3305 if (e
->value
.character
.length
!= 1)
3307 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
3308 return &gfc_bad_expr
;
3311 index
= e
->value
.character
.string
[0];
3313 if (warn_surprising
&& index
> 127)
3314 gfc_warning (OPT_Wsurprising
,
3315 "Argument of IACHAR function at %L outside of range 0..127",
3318 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
3320 return &gfc_bad_expr
;
3322 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3324 return range_check (result
, "IACHAR");
3329 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
3331 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3332 gcc_assert (result
->ts
.type
== BT_INTEGER
3333 && result
->expr_type
== EXPR_CONSTANT
);
3335 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3341 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3343 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
3348 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
3350 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3351 gcc_assert (result
->ts
.type
== BT_INTEGER
3352 && result
->expr_type
== EXPR_CONSTANT
);
3354 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3360 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3362 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
3367 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
3371 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3374 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3375 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3377 return range_check (result
, "IAND");
3382 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
3387 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3390 if (!gfc_check_bitfcn (x
, y
))
3391 return &gfc_bad_expr
;
3393 gfc_extract_int (y
, &pos
);
3395 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3397 result
= gfc_copy_expr (x
);
3398 /* Drop any separate memory representation of x to avoid potential
3399 inconsistencies in result. */
3400 if (result
->representation
.string
)
3402 free (result
->representation
.string
);
3403 result
->representation
.string
= NULL
;
3406 convert_mpz_to_unsigned (result
->value
.integer
,
3407 gfc_integer_kinds
[k
].bit_size
);
3409 mpz_clrbit (result
->value
.integer
, pos
);
3411 gfc_convert_mpz_to_signed (result
->value
.integer
,
3412 gfc_integer_kinds
[k
].bit_size
);
3419 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
3426 if (x
->expr_type
!= EXPR_CONSTANT
3427 || y
->expr_type
!= EXPR_CONSTANT
3428 || z
->expr_type
!= EXPR_CONSTANT
)
3431 if (!gfc_check_ibits (x
, y
, z
))
3432 return &gfc_bad_expr
;
3434 gfc_extract_int (y
, &pos
);
3435 gfc_extract_int (z
, &len
);
3437 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
3439 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3441 if (pos
+ len
> bitsize
)
3443 gfc_error ("Sum of second and third arguments of IBITS exceeds "
3444 "bit size at %L", &y
->where
);
3445 return &gfc_bad_expr
;
3448 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3449 convert_mpz_to_unsigned (result
->value
.integer
,
3450 gfc_integer_kinds
[k
].bit_size
);
3452 bits
= XCNEWVEC (int, bitsize
);
3454 for (i
= 0; i
< bitsize
; i
++)
3457 for (i
= 0; i
< len
; i
++)
3458 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
3460 for (i
= 0; i
< bitsize
; i
++)
3463 mpz_clrbit (result
->value
.integer
, i
);
3464 else if (bits
[i
] == 1)
3465 mpz_setbit (result
->value
.integer
, i
);
3467 gfc_internal_error ("IBITS: Bad bit");
3472 gfc_convert_mpz_to_signed (result
->value
.integer
,
3473 gfc_integer_kinds
[k
].bit_size
);
3480 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
3485 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3488 if (!gfc_check_bitfcn (x
, y
))
3489 return &gfc_bad_expr
;
3491 gfc_extract_int (y
, &pos
);
3493 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3495 result
= gfc_copy_expr (x
);
3496 /* Drop any separate memory representation of x to avoid potential
3497 inconsistencies in result. */
3498 if (result
->representation
.string
)
3500 free (result
->representation
.string
);
3501 result
->representation
.string
= NULL
;
3504 convert_mpz_to_unsigned (result
->value
.integer
,
3505 gfc_integer_kinds
[k
].bit_size
);
3507 mpz_setbit (result
->value
.integer
, pos
);
3509 gfc_convert_mpz_to_signed (result
->value
.integer
,
3510 gfc_integer_kinds
[k
].bit_size
);
3517 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
3523 if (e
->expr_type
!= EXPR_CONSTANT
)
3526 if (e
->value
.character
.length
!= 1)
3528 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
3529 return &gfc_bad_expr
;
3532 index
= e
->value
.character
.string
[0];
3534 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
3536 return &gfc_bad_expr
;
3538 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3540 return range_check (result
, "ICHAR");
3545 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
3549 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3552 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3553 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3555 return range_check (result
, "IEOR");
3560 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
3564 HOST_WIDE_INT len
, lensub
, start
, last
, i
, index
= 0;
3567 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
3568 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
3571 back
= (b
!= NULL
&& b
->value
.logical
!= 0);
3573 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
3575 return &gfc_bad_expr
;
3577 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
3579 len
= x
->value
.character
.length
;
3580 lensub
= y
->value
.character
.length
;
3584 mpz_set_si (result
->value
.integer
, 0);
3599 last
= len
+ 1 - lensub
;
3606 start
= len
- lensub
;
3610 for (; start
!= last
; start
+= delta
)
3612 for (i
= 0; i
< lensub
; i
++)
3614 if (x
->value
.character
.string
[start
+ i
]
3615 != y
->value
.character
.string
[i
])
3626 mpz_set_si (result
->value
.integer
, index
);
3627 return range_check (result
, "INDEX");
3632 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
3634 gfc_expr
*result
= NULL
;
3637 /* Convert BOZ to integer, and return without range checking. */
3638 if (e
->ts
.type
== BT_BOZ
)
3640 if (!gfc_boz2int (e
, kind
))
3642 result
= gfc_copy_expr (e
);
3646 if (e
->expr_type
!= EXPR_CONSTANT
)
3649 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
3651 tmp1
= warn_conversion
;
3652 tmp2
= warn_conversion_extra
;
3653 warn_conversion
= warn_conversion_extra
= 0;
3655 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
3657 warn_conversion
= tmp1
;
3658 warn_conversion_extra
= tmp2
;
3660 if (result
== &gfc_bad_expr
)
3661 return &gfc_bad_expr
;
3663 return range_check (result
, name
);
3668 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
3672 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
3674 return &gfc_bad_expr
;
3676 return simplify_intconv (e
, kind
, "INT");
3680 gfc_simplify_int2 (gfc_expr
*e
)
3682 return simplify_intconv (e
, 2, "INT2");
3687 gfc_simplify_int8 (gfc_expr
*e
)
3689 return simplify_intconv (e
, 8, "INT8");
3694 gfc_simplify_long (gfc_expr
*e
)
3696 return simplify_intconv (e
, 4, "LONG");
3701 gfc_simplify_ifix (gfc_expr
*e
)
3703 gfc_expr
*rtrunc
, *result
;
3705 if (e
->expr_type
!= EXPR_CONSTANT
)
3708 rtrunc
= gfc_copy_expr (e
);
3709 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3711 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3713 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3715 gfc_free_expr (rtrunc
);
3717 return range_check (result
, "IFIX");
3722 gfc_simplify_idint (gfc_expr
*e
)
3724 gfc_expr
*rtrunc
, *result
;
3726 if (e
->expr_type
!= EXPR_CONSTANT
)
3729 rtrunc
= gfc_copy_expr (e
);
3730 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3732 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3734 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3736 gfc_free_expr (rtrunc
);
3738 return range_check (result
, "IDINT");
3743 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
3747 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3750 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3751 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3753 return range_check (result
, "IOR");
3758 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
3760 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3761 gcc_assert (result
->ts
.type
== BT_INTEGER
3762 && result
->expr_type
== EXPR_CONSTANT
);
3764 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3770 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3772 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3777 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3779 if (x
->expr_type
!= EXPR_CONSTANT
)
3782 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3783 mpz_cmp_si (x
->value
.integer
,
3784 LIBERROR_END
) == 0);
3789 gfc_simplify_is_iostat_eor (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_EOR
) == 0);
3801 gfc_simplify_isnan (gfc_expr
*x
)
3803 if (x
->expr_type
!= EXPR_CONSTANT
)
3806 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3807 mpfr_nan_p (x
->value
.real
));
3811 /* Performs a shift on its first argument. Depending on the last
3812 argument, the shift can be arithmetic, i.e. with filling from the
3813 left like in the SHIFTA intrinsic. */
3815 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3816 bool arithmetic
, int direction
)
3819 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3821 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3824 gfc_extract_int (s
, &shift
);
3826 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3827 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3829 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3833 mpz_set (result
->value
.integer
, e
->value
.integer
);
3837 if (direction
> 0 && shift
< 0)
3839 /* Left shift, as in SHIFTL. */
3840 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3841 return &gfc_bad_expr
;
3843 else if (direction
< 0)
3845 /* Right shift, as in SHIFTR or SHIFTA. */
3848 gfc_error ("Second argument of %s is negative at %L",
3850 return &gfc_bad_expr
;
3856 ashift
= (shift
>= 0 ? shift
: -shift
);
3858 if (ashift
> bitsize
)
3860 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3861 "at %L", name
, &e
->where
);
3862 return &gfc_bad_expr
;
3865 bits
= XCNEWVEC (int, bitsize
);
3867 for (i
= 0; i
< bitsize
; i
++)
3868 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3873 for (i
= 0; i
< shift
; i
++)
3874 mpz_clrbit (result
->value
.integer
, i
);
3876 for (i
= 0; i
< bitsize
- shift
; i
++)
3879 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3881 mpz_setbit (result
->value
.integer
, i
+ shift
);
3887 if (arithmetic
&& bits
[bitsize
- 1])
3888 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3889 mpz_setbit (result
->value
.integer
, i
);
3891 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3892 mpz_clrbit (result
->value
.integer
, i
);
3894 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3897 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3899 mpz_setbit (result
->value
.integer
, i
- ashift
);
3903 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3911 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3913 return simplify_shift (e
, s
, "ISHFT", false, 0);
3918 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3920 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3925 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3927 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3932 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3934 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3939 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3941 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3946 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3948 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3953 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3956 int shift
, ashift
, isize
, ssize
, delta
, k
;
3959 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3962 gfc_extract_int (s
, &shift
);
3964 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3965 isize
= gfc_integer_kinds
[k
].bit_size
;
3969 if (sz
->expr_type
!= EXPR_CONSTANT
)
3972 gfc_extract_int (sz
, &ssize
);
3974 if (ssize
> isize
|| ssize
<= 0)
3975 return &gfc_bad_expr
;
3988 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3989 "BIT_SIZE of first argument at %C");
3991 gfc_error ("Absolute value of SHIFT shall be less than or equal "
3993 return &gfc_bad_expr
;
3996 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3998 mpz_set (result
->value
.integer
, e
->value
.integer
);
4003 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
4005 bits
= XCNEWVEC (int, ssize
);
4007 for (i
= 0; i
< ssize
; i
++)
4008 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
4010 delta
= ssize
- ashift
;
4014 for (i
= 0; i
< delta
; i
++)
4017 mpz_clrbit (result
->value
.integer
, i
+ shift
);
4019 mpz_setbit (result
->value
.integer
, i
+ shift
);
4022 for (i
= delta
; i
< ssize
; i
++)
4025 mpz_clrbit (result
->value
.integer
, i
- delta
);
4027 mpz_setbit (result
->value
.integer
, i
- delta
);
4032 for (i
= 0; i
< ashift
; i
++)
4035 mpz_clrbit (result
->value
.integer
, i
+ delta
);
4037 mpz_setbit (result
->value
.integer
, i
+ delta
);
4040 for (i
= ashift
; i
< ssize
; i
++)
4043 mpz_clrbit (result
->value
.integer
, i
+ shift
);
4045 mpz_setbit (result
->value
.integer
, i
+ shift
);
4049 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
4057 gfc_simplify_kind (gfc_expr
*e
)
4059 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
4064 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
4065 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
4067 gfc_expr
*l
, *u
, *result
;
4070 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4071 gfc_default_integer_kind
);
4073 return &gfc_bad_expr
;
4075 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4077 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
4078 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
4079 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
4083 gfc_expr
* dim
= result
;
4084 mpz_set_si (dim
->value
.integer
, d
);
4086 result
= simplify_size (array
, dim
, k
);
4087 gfc_free_expr (dim
);
4092 mpz_set_si (result
->value
.integer
, 1);
4097 /* Otherwise, we have a variable expression. */
4098 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
4101 if (!gfc_resolve_array_spec (as
, 0))
4104 /* The last dimension of an assumed-size array is special. */
4105 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
4106 || (coarray
&& d
== as
->rank
+ as
->corank
4107 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
4109 if (as
->lower
[d
-1] && as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
4111 gfc_free_expr (result
);
4112 return gfc_copy_expr (as
->lower
[d
-1]);
4118 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4120 /* Then, we need to know the extent of the given dimension. */
4121 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
4123 gfc_expr
*declared_bound
;
4125 bool constant_lbound
, constant_ubound
;
4130 gcc_assert (l
!= NULL
);
4132 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
4133 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
4135 empty_bound
= upper
? 0 : 1;
4136 declared_bound
= upper
? u
: l
;
4138 if ((!upper
&& !constant_lbound
)
4139 || (upper
&& !constant_ubound
))
4144 /* For {L,U}BOUND, the value depends on whether the array
4145 is empty. We can nevertheless simplify if the declared bound
4146 has the same value as that of an empty array, in which case
4147 the result isn't dependent on the array emptiness. */
4148 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
4149 mpz_set_si (result
->value
.integer
, empty_bound
);
4150 else if (!constant_lbound
|| !constant_ubound
)
4151 /* Array emptiness can't be determined, we can't simplify. */
4153 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
4154 mpz_set_si (result
->value
.integer
, empty_bound
);
4156 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4159 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4165 int d2
= 0, cnt
= 0;
4166 for (int idx
= 0; idx
< ref
->u
.ar
.dimen
; ++idx
)
4168 if (ref
->u
.ar
.dimen_type
[idx
] == DIMEN_ELEMENT
)
4170 else if (cnt
< d
- 1)
4175 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d2
+ d
- 1, &result
->value
.integer
, NULL
))
4179 mpz_set_si (result
->value
.integer
, (long int) 1);
4183 return range_check (result
, upper
? "UBOUND" : "LBOUND");
4186 gfc_free_expr (result
);
4192 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4196 ar_type type
= AR_UNKNOWN
;
4199 if (array
->ts
.type
== BT_CLASS
)
4202 if (array
->expr_type
!= EXPR_VARIABLE
)
4209 /* Do not attempt to resolve if error has already been issued. */
4210 if (array
->symtree
->n
.sym
->error
)
4213 /* Follow any component references. */
4214 as
= array
->symtree
->n
.sym
->as
;
4215 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4220 type
= ref
->u
.ar
.type
;
4221 switch (ref
->u
.ar
.type
)
4228 /* We're done because 'as' has already been set in the
4229 previous iteration. */
4243 as
= ref
->u
.c
.component
->as
;
4256 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
4257 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
4260 /* 'array' shall not be an unallocated allocatable variable or a pointer that
4261 is not associated. */
4262 if (array
->expr_type
== EXPR_VARIABLE
4263 && (gfc_expr_attr (array
).allocatable
|| gfc_expr_attr (array
).pointer
))
4267 || (as
->type
!= AS_DEFERRED
4268 && array
->expr_type
== EXPR_VARIABLE
4269 && !gfc_expr_attr (array
).allocatable
4270 && !gfc_expr_attr (array
).pointer
));
4274 /* Multi-dimensional bounds. */
4275 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4279 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4280 if (upper
&& type
== AR_FULL
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
4282 /* An error message will be emitted in
4283 check_assumed_size_reference (resolve.cc). */
4284 return &gfc_bad_expr
;
4287 /* Simplify the bounds for each dimension. */
4288 for (d
= 0; d
< array
->rank
; d
++)
4290 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
4292 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4296 for (j
= 0; j
< d
; j
++)
4297 gfc_free_expr (bounds
[j
]);
4300 return &gfc_bad_expr
;
4306 /* Allocate the result expression. */
4307 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4308 gfc_default_integer_kind
);
4310 return &gfc_bad_expr
;
4312 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
4314 /* The result is a rank 1 array; its size is the rank of the first
4315 argument to {L,U}BOUND. */
4317 e
->shape
= gfc_get_shape (1);
4318 mpz_init_set_ui (e
->shape
[0], array
->rank
);
4320 /* Create the constructor for this array. */
4321 for (d
= 0; d
< array
->rank
; d
++)
4322 gfc_constructor_append_expr (&e
->value
.constructor
,
4323 bounds
[d
], &e
->where
);
4329 /* A DIM argument is specified. */
4330 if (dim
->expr_type
!= EXPR_CONSTANT
)
4333 d
= mpz_get_si (dim
->value
.integer
);
4335 if ((d
< 1 || d
> array
->rank
)
4336 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
4338 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4339 return &gfc_bad_expr
;
4342 if (as
&& as
->type
== AS_ASSUMED_RANK
)
4345 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
4351 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4357 if (array
->expr_type
!= EXPR_VARIABLE
)
4360 /* Follow any component references. */
4361 as
= (array
->ts
.type
== BT_CLASS
&& CLASS_DATA (array
))
4362 ? CLASS_DATA (array
)->as
4363 : array
->symtree
->n
.sym
->as
;
4364 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4369 switch (ref
->u
.ar
.type
)
4372 if (ref
->u
.ar
.as
->corank
> 0)
4374 gcc_assert (as
== ref
->u
.ar
.as
);
4381 /* We're done because 'as' has already been set in the
4382 previous iteration. */
4396 as
= ref
->u
.c
.component
->as
;
4410 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
4415 /* Multi-dimensional cobounds. */
4416 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4420 /* Simplify the cobounds for each dimension. */
4421 for (d
= 0; d
< as
->corank
; d
++)
4423 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
4424 upper
, as
, ref
, true);
4425 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4429 for (j
= 0; j
< d
; j
++)
4430 gfc_free_expr (bounds
[j
]);
4435 /* Allocate the result expression. */
4436 e
= gfc_get_expr ();
4437 e
->where
= array
->where
;
4438 e
->expr_type
= EXPR_ARRAY
;
4439 e
->ts
.type
= BT_INTEGER
;
4440 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
4441 gfc_default_integer_kind
);
4445 return &gfc_bad_expr
;
4449 /* The result is a rank 1 array; its size is the rank of the first
4450 argument to {L,U}COBOUND. */
4452 e
->shape
= gfc_get_shape (1);
4453 mpz_init_set_ui (e
->shape
[0], as
->corank
);
4455 /* Create the constructor for this array. */
4456 for (d
= 0; d
< as
->corank
; d
++)
4457 gfc_constructor_append_expr (&e
->value
.constructor
,
4458 bounds
[d
], &e
->where
);
4463 /* A DIM argument is specified. */
4464 if (dim
->expr_type
!= EXPR_CONSTANT
)
4467 d
= mpz_get_si (dim
->value
.integer
);
4469 if (d
< 1 || d
> as
->corank
)
4471 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4472 return &gfc_bad_expr
;
4475 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
4481 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4483 return simplify_bound (array
, dim
, kind
, 0);
4488 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4490 return simplify_cobound (array
, dim
, kind
, 0);
4494 gfc_simplify_leadz (gfc_expr
*e
)
4496 unsigned long lz
, bs
;
4499 if (e
->expr_type
!= EXPR_CONSTANT
)
4502 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4503 bs
= gfc_integer_kinds
[i
].bit_size
;
4504 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
4506 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
4509 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
4511 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
4515 /* Check for constant length of a substring. */
4518 substring_has_constant_len (gfc_expr
*e
)
4521 HOST_WIDE_INT istart
, iend
, length
;
4522 bool equal_length
= false;
4524 if (e
->ts
.type
!= BT_CHARACTER
)
4527 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4528 if (ref
->type
!= REF_COMPONENT
&& ref
->type
!= REF_ARRAY
)
4532 || ref
->type
!= REF_SUBSTRING
4534 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
4536 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
4539 /* Basic checks on substring starting and ending indices. */
4540 if (!gfc_resolve_substring (ref
, &equal_length
))
4543 istart
= gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
);
4544 iend
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
);
4547 length
= iend
- istart
+ 1;
4551 /* Fix substring length. */
4552 e
->value
.character
.length
= length
;
4559 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
4562 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
4565 return &gfc_bad_expr
;
4567 if (e
->expr_type
== EXPR_CONSTANT
4568 || substring_has_constant_len (e
))
4570 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4571 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
4572 return range_check (result
, "LEN");
4574 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
4575 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
4576 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
4578 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4579 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
4580 return range_check (result
, "LEN");
4582 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
4583 && e
->symtree
->n
.sym
)
4585 if (e
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
4586 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
4587 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
4588 && e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
4589 && UNLIMITED_POLY (e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
))
4590 /* The expression in assoc->target points to a ref to the _data
4591 component of the unlimited polymorphic entity. To get the _len
4592 component the last _data ref needs to be stripped and a ref to the
4593 _len component added. */
4594 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
, k
);
4595 else if (e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
4596 && e
->ref
&& e
->ref
->type
== REF_COMPONENT
4597 && e
->ref
->u
.c
.component
->attr
.pdt_string
4598 && e
->ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4599 && e
->ref
->u
.c
.component
->ts
.u
.cl
->length
)
4601 if (gfc_init_expr_flag
)
4604 tmp
= gfc_pdt_find_component_copy_initializer (e
->symtree
->n
.sym
,
4614 gfc_expr
*len_expr
= gfc_copy_expr (e
);
4615 gfc_free_ref_list (len_expr
->ref
);
4616 len_expr
->ref
= NULL
;
4617 gfc_find_component (len_expr
->symtree
->n
.sym
->ts
.u
.derived
, e
->ref
4618 ->u
.c
.component
->ts
.u
.cl
->length
->symtree
4620 false, true, &len_expr
->ref
);
4621 len_expr
->ts
= len_expr
->ref
->u
.c
.component
->ts
;
4631 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
4634 size_t count
, len
, i
;
4635 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
4638 return &gfc_bad_expr
;
4640 if (e
->expr_type
!= EXPR_CONSTANT
)
4643 len
= e
->value
.character
.length
;
4644 for (count
= 0, i
= 1; i
<= len
; i
++)
4645 if (e
->value
.character
.string
[len
- i
] == ' ')
4650 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
4651 return range_check (result
, "LEN_TRIM");
4655 gfc_simplify_lgamma (gfc_expr
*x
)
4660 if (x
->expr_type
!= EXPR_CONSTANT
)
4663 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4664 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
4666 return range_check (result
, "LGAMMA");
4671 gfc_simplify_lge (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_lgt (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_lle (gfc_expr
*a
, gfc_expr
*b
)
4695 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4698 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4699 gfc_compare_string (a
, b
) <= 0);
4704 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
4706 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4709 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4710 gfc_compare_string (a
, b
) < 0);
4715 gfc_simplify_log (gfc_expr
*x
)
4719 if (x
->expr_type
!= EXPR_CONSTANT
)
4722 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4727 if (mpfr_sgn (x
->value
.real
) <= 0)
4729 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4730 "to zero", &x
->where
);
4731 gfc_free_expr (result
);
4732 return &gfc_bad_expr
;
4735 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4739 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
4740 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
4742 gfc_error ("Complex argument of LOG at %L cannot be zero",
4744 gfc_free_expr (result
);
4745 return &gfc_bad_expr
;
4748 gfc_set_model_kind (x
->ts
.kind
);
4749 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
4753 gfc_internal_error ("gfc_simplify_log: bad type");
4756 return range_check (result
, "LOG");
4761 gfc_simplify_log10 (gfc_expr
*x
)
4765 if (x
->expr_type
!= EXPR_CONSTANT
)
4768 if (mpfr_sgn (x
->value
.real
) <= 0)
4770 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4771 "to zero", &x
->where
);
4772 return &gfc_bad_expr
;
4775 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4776 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4778 return range_check (result
, "LOG10");
4783 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
4787 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
4789 return &gfc_bad_expr
;
4791 if (e
->expr_type
!= EXPR_CONSTANT
)
4794 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
4799 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
4802 int row
, result_rows
, col
, result_columns
;
4803 int stride_a
, offset_a
, stride_b
, offset_b
;
4805 if (!is_constant_array_expr (matrix_a
)
4806 || !is_constant_array_expr (matrix_b
))
4809 /* MATMUL should do mixed-mode arithmetic. Set the result type. */
4810 if (matrix_a
->ts
.type
!= matrix_b
->ts
.type
)
4813 e
.expr_type
= EXPR_OP
;
4814 gfc_clear_ts (&e
.ts
);
4815 e
.value
.op
.op
= INTRINSIC_NONE
;
4816 e
.value
.op
.op1
= matrix_a
;
4817 e
.value
.op
.op2
= matrix_b
;
4818 gfc_type_convert_binary (&e
, 1);
4819 result
= gfc_get_array_expr (e
.ts
.type
, e
.ts
.kind
, &matrix_a
->where
);
4823 result
= gfc_get_array_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
4827 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
4830 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
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_columns
);
4838 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
4840 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4842 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4846 result
->shape
= gfc_get_shape (result
->rank
);
4847 mpz_init_set_si (result
->shape
[0], result_rows
);
4849 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
4851 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4852 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4853 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4854 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4857 result
->shape
= gfc_get_shape (result
->rank
);
4858 mpz_init_set_si (result
->shape
[0], result_rows
);
4859 mpz_init_set_si (result
->shape
[1], result_columns
);
4865 for (col
= 0; col
< result_columns
; ++col
)
4869 for (row
= 0; row
< result_rows
; ++row
)
4871 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
4872 matrix_b
, 1, offset_b
, false);
4873 gfc_constructor_append_expr (&result
->value
.constructor
,
4879 offset_b
+= stride_b
;
4887 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
4892 if (i
->expr_type
!= EXPR_CONSTANT
)
4895 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
4897 return &gfc_bad_expr
;
4898 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4900 bool fail
= gfc_extract_int (i
, &arg
);
4903 if (!gfc_check_mask (i
, kind_arg
))
4904 return &gfc_bad_expr
;
4906 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4908 /* MASKR(n) = 2^n - 1 */
4909 mpz_set_ui (result
->value
.integer
, 1);
4910 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4911 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4913 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4920 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4926 if (i
->expr_type
!= EXPR_CONSTANT
)
4929 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4931 return &gfc_bad_expr
;
4932 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4934 bool fail
= gfc_extract_int (i
, &arg
);
4937 if (!gfc_check_mask (i
, kind_arg
))
4938 return &gfc_bad_expr
;
4940 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4942 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4943 mpz_init_set_ui (z
, 1);
4944 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4945 mpz_set_ui (result
->value
.integer
, 1);
4946 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4947 gfc_integer_kinds
[k
].bit_size
- arg
);
4948 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4951 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4958 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4961 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4963 if (mask
->expr_type
== EXPR_CONSTANT
)
4965 /* The standard requires evaluation of all function arguments.
4966 Simplify only when the other dropped argument (FSOURCE or TSOURCE)
4967 is a constant expression. */
4968 if (mask
->value
.logical
)
4970 if (!gfc_is_constant_expr (fsource
))
4972 result
= gfc_copy_expr (tsource
);
4976 if (!gfc_is_constant_expr (tsource
))
4978 result
= gfc_copy_expr (fsource
);
4981 /* Parenthesis is needed to get lower bounds of 1. */
4982 result
= gfc_get_parentheses (result
);
4983 gfc_simplify_expr (result
, 1);
4987 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4988 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4991 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4993 if (tsource
->ts
.type
== BT_DERIVED
)
4994 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4995 else if (tsource
->ts
.type
== BT_CHARACTER
)
4996 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4998 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4999 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
5000 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5004 if (mask_ctor
->expr
->value
.logical
)
5005 gfc_constructor_append_expr (&result
->value
.constructor
,
5006 gfc_copy_expr (tsource_ctor
->expr
),
5009 gfc_constructor_append_expr (&result
->value
.constructor
,
5010 gfc_copy_expr (fsource_ctor
->expr
),
5012 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
5013 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
5014 mask_ctor
= gfc_constructor_next (mask_ctor
);
5017 result
->shape
= gfc_get_shape (1);
5018 gfc_array_size (result
, &result
->shape
[0]);
5025 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
5027 mpz_t arg1
, arg2
, mask
;
5030 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
5031 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
5034 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
5036 /* Convert all argument to unsigned. */
5037 mpz_init_set (arg1
, i
->value
.integer
);
5038 mpz_init_set (arg2
, j
->value
.integer
);
5039 mpz_init_set (mask
, mask_expr
->value
.integer
);
5041 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
5042 mpz_and (arg1
, arg1
, mask
);
5043 mpz_com (mask
, mask
);
5044 mpz_and (arg2
, arg2
, mask
);
5045 mpz_ior (result
->value
.integer
, arg1
, arg2
);
5055 /* Selects between current value and extremum for simplify_min_max
5056 and simplify_minval_maxval. */
5058 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
, bool back_val
)
5062 switch (arg
->ts
.type
)
5065 if (extremum
->ts
.kind
< arg
->ts
.kind
)
5066 extremum
->ts
.kind
= arg
->ts
.kind
;
5067 ret
= mpz_cmp (arg
->value
.integer
,
5068 extremum
->value
.integer
) * sign
;
5070 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
5074 if (extremum
->ts
.kind
< arg
->ts
.kind
)
5075 extremum
->ts
.kind
= arg
->ts
.kind
;
5076 if (mpfr_nan_p (extremum
->value
.real
))
5079 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
5081 else if (mpfr_nan_p (arg
->value
.real
))
5085 ret
= mpfr_cmp (arg
->value
.real
, extremum
->value
.real
) * sign
;
5087 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
5092 #define LENGTH(x) ((x)->value.character.length)
5093 #define STRING(x) ((x)->value.character.string)
5094 if (LENGTH (extremum
) < LENGTH(arg
))
5096 gfc_char_t
*tmp
= STRING(extremum
);
5098 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
5099 memcpy (STRING(extremum
), tmp
,
5100 LENGTH(extremum
) * sizeof (gfc_char_t
));
5101 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
5102 LENGTH(arg
) - LENGTH(extremum
));
5103 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
5104 LENGTH(extremum
) = LENGTH(arg
);
5107 ret
= gfc_compare_string (arg
, extremum
) * sign
;
5110 free (STRING(extremum
));
5111 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
5112 memcpy (STRING(extremum
), STRING(arg
),
5113 LENGTH(arg
) * sizeof (gfc_char_t
));
5114 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
5115 LENGTH(extremum
) - LENGTH(arg
));
5116 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
5123 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5125 if (back_val
&& ret
== 0)
5132 /* This function is special since MAX() can take any number of
5133 arguments. The simplified expression is a rewritten version of the
5134 argument list containing at most one constant element. Other
5135 constant elements are deleted. Because the argument list has
5136 already been checked, this function always succeeds. sign is 1 for
5137 MAX(), -1 for MIN(). */
5140 simplify_min_max (gfc_expr
*expr
, int sign
)
5143 gfc_actual_arglist
*arg
, *last
, *extremum
;
5144 gfc_expr
*tmp
, *ret
;
5150 arg
= expr
->value
.function
.actual
;
5152 for (; arg
; last
= arg
, arg
= arg
->next
)
5154 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
5157 if (extremum
== NULL
)
5163 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
5165 /* Delete the extra constant argument. */
5166 last
->next
= arg
->next
;
5169 gfc_free_actual_arglist (arg
);
5173 /* If there is one value left, replace the function call with the
5175 if (expr
->value
.function
.actual
->next
!= NULL
)
5178 /* Handle special cases of specific functions (min|max)1 and
5181 tmp
= expr
->value
.function
.actual
->expr
;
5182 fname
= expr
->value
.function
.isym
->name
;
5184 if ((tmp
->ts
.type
!= BT_INTEGER
|| tmp
->ts
.kind
!= gfc_integer_4_kind
)
5185 && (strcmp (fname
, "min1") == 0 || strcmp (fname
, "max1") == 0))
5187 /* Explicit conversion, turn off -Wconversion and -Wconversion-extra
5189 tmp1
= warn_conversion
;
5190 tmp2
= warn_conversion_extra
;
5191 warn_conversion
= warn_conversion_extra
= 0;
5193 ret
= gfc_convert_constant (tmp
, BT_INTEGER
, gfc_integer_4_kind
);
5195 warn_conversion
= tmp1
;
5196 warn_conversion_extra
= tmp2
;
5198 else if ((tmp
->ts
.type
!= BT_REAL
|| tmp
->ts
.kind
!= gfc_real_4_kind
)
5199 && (strcmp (fname
, "amin0") == 0 || strcmp (fname
, "amax0") == 0))
5201 ret
= gfc_convert_constant (tmp
, BT_REAL
, gfc_real_4_kind
);
5204 ret
= gfc_copy_expr (tmp
);
5212 gfc_simplify_min (gfc_expr
*e
)
5214 return simplify_min_max (e
, -1);
5219 gfc_simplify_max (gfc_expr
*e
)
5221 return simplify_min_max (e
, 1);
5224 /* Helper function for gfc_simplify_minval. */
5227 gfc_min (gfc_expr
*op1
, gfc_expr
*op2
)
5229 min_max_choose (op1
, op2
, -1);
5230 gfc_free_expr (op1
);
5234 /* Simplify minval for constant arrays. */
5237 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5239 return simplify_transformation (array
, dim
, mask
, INT_MAX
, gfc_min
);
5242 /* Helper function for gfc_simplify_maxval. */
5245 gfc_max (gfc_expr
*op1
, gfc_expr
*op2
)
5247 min_max_choose (op1
, op2
, 1);
5248 gfc_free_expr (op1
);
5253 /* Simplify maxval for constant arrays. */
5256 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5258 return simplify_transformation (array
, dim
, mask
, INT_MIN
, gfc_max
);
5262 /* Transform minloc or maxloc of an array, according to MASK,
5263 to the scalar result. This code is mostly identical to
5264 simplify_transformation_to_scalar. */
5267 simplify_minmaxloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
5268 gfc_expr
*extremum
, int sign
, bool back_val
)
5271 gfc_constructor
*array_ctor
, *mask_ctor
;
5274 mpz_set_si (result
->value
.integer
, 0);
5277 /* Shortcut for constant .FALSE. MASK. */
5279 && mask
->expr_type
== EXPR_CONSTANT
5280 && !mask
->value
.logical
)
5283 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5284 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5285 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5289 mpz_init_set_si (count
, 0);
5292 mpz_add_ui (count
, count
, 1);
5293 a
= array_ctor
->expr
;
5294 array_ctor
= gfc_constructor_next (array_ctor
);
5295 /* A constant MASK equals .TRUE. here and can be ignored. */
5298 m
= mask_ctor
->expr
;
5299 mask_ctor
= gfc_constructor_next (mask_ctor
);
5300 if (!m
->value
.logical
)
5303 if (min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5304 mpz_set (result
->value
.integer
, count
);
5307 gfc_free_expr (extremum
);
5311 /* Simplify minloc / maxloc in the absence of a dim argument. */
5314 simplify_minmaxloc_nodim (gfc_expr
*result
, gfc_expr
*extremum
,
5315 gfc_expr
*array
, gfc_expr
*mask
, int sign
,
5318 ssize_t res
[GFC_MAX_DIMENSIONS
];
5320 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5321 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5322 sstride
[GFC_MAX_DIMENSIONS
];
5327 for (i
= 0; i
<array
->rank
; i
++)
5330 /* Shortcut for constant .FALSE. MASK. */
5332 && mask
->expr_type
== EXPR_CONSTANT
5333 && !mask
->value
.logical
)
5336 if (array
->shape
== NULL
)
5339 for (i
= 0; i
< array
->rank
; i
++)
5342 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5343 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5348 continue_loop
= true;
5349 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5350 if (mask
&& mask
->rank
> 0)
5351 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5355 /* Loop over the array elements (and mask), keeping track of
5356 the indices to return. */
5357 while (continue_loop
)
5361 a
= array_ctor
->expr
;
5364 m
= mask_ctor
->expr
;
5365 ma
= m
->value
.logical
;
5366 mask_ctor
= gfc_constructor_next (mask_ctor
);
5371 if (ma
&& min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5373 for (i
= 0; i
<array
->rank
; i
++)
5376 array_ctor
= gfc_constructor_next (array_ctor
);
5378 } while (count
[0] != extent
[0]);
5382 /* When we get to the end of a dimension, reset it and increment
5383 the next dimension. */
5386 if (n
>= array
->rank
)
5388 continue_loop
= false;
5393 } while (count
[n
] == extent
[n
]);
5397 gfc_free_expr (extremum
);
5398 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5399 for (i
= 0; i
<array
->rank
; i
++)
5402 r_expr
= result_ctor
->expr
;
5403 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5404 result_ctor
= gfc_constructor_next (result_ctor
);
5409 /* Helper function for gfc_simplify_minmaxloc - build an array
5410 expression with n elements. */
5413 new_array (bt type
, int kind
, int n
, locus
*where
)
5418 result
= gfc_get_array_expr (type
, kind
, where
);
5420 result
->shape
= gfc_get_shape(1);
5421 mpz_init_set_si (result
->shape
[0], n
);
5422 for (i
= 0; i
< n
; i
++)
5424 gfc_constructor_append_expr (&result
->value
.constructor
,
5425 gfc_get_constant_expr (type
, kind
, where
),
5432 /* Simplify minloc and maxloc. This code is mostly identical to
5433 simplify_transformation_to_array. */
5436 simplify_minmaxloc_to_array (gfc_expr
*result
, gfc_expr
*array
,
5437 gfc_expr
*dim
, gfc_expr
*mask
,
5438 gfc_expr
*extremum
, int sign
, bool back_val
)
5441 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5442 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5443 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5445 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5446 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5447 tmpstride
[GFC_MAX_DIMENSIONS
];
5449 /* Shortcut for constant .FALSE. MASK. */
5451 && mask
->expr_type
== EXPR_CONSTANT
5452 && !mask
->value
.logical
)
5455 /* Build an indexed table for array element expressions to minimize
5456 linked-list traversal. Masked elements are set to NULL. */
5457 gfc_array_size (array
, &size
);
5458 arraysize
= mpz_get_ui (size
);
5461 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5463 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5465 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5466 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5468 for (i
= 0; i
< arraysize
; ++i
)
5470 arrayvec
[i
] = array_ctor
->expr
;
5471 array_ctor
= gfc_constructor_next (array_ctor
);
5475 if (!mask_ctor
->expr
->value
.logical
)
5478 mask_ctor
= gfc_constructor_next (mask_ctor
);
5482 /* Same for the result expression. */
5483 gfc_array_size (result
, &size
);
5484 resultsize
= mpz_get_ui (size
);
5487 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5488 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5489 for (i
= 0; i
< resultsize
; ++i
)
5491 resultvec
[i
] = result_ctor
->expr
;
5492 result_ctor
= gfc_constructor_next (result_ctor
);
5495 gfc_extract_int (dim
, &dim_index
);
5496 dim_index
-= 1; /* zero-base index */
5500 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5503 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5506 dim_extent
= mpz_get_si (array
->shape
[i
]);
5507 dim_stride
= tmpstride
[i
];
5511 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5512 sstride
[n
] = tmpstride
[i
];
5513 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5517 done
= resultsize
<= 0;
5523 ex
= gfc_copy_expr (extremum
);
5524 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5526 if (*src
&& min_max_choose (*src
, ex
, sign
, back_val
) > 0)
5527 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5536 while (!done
&& count
[n
] == extent
[n
])
5539 base
-= sstride
[n
] * extent
[n
];
5540 dest
-= dstride
[n
] * extent
[n
];
5543 if (n
< result
->rank
)
5545 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5546 times, we'd warn for the last iteration, because the
5547 array index will have already been incremented to the
5548 array sizes, and we can't tell that this must make
5549 the test against result->rank false, because ranks
5550 must not exceed GFC_MAX_DIMENSIONS. */
5551 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5562 /* Place updated expression in result constructor. */
5563 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5564 for (i
= 0; i
< resultsize
; ++i
)
5566 result_ctor
->expr
= resultvec
[i
];
5567 result_ctor
= gfc_constructor_next (result_ctor
);
5576 /* Simplify minloc and maxloc for constant arrays. */
5579 gfc_simplify_minmaxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
5580 gfc_expr
*kind
, gfc_expr
*back
, int sign
)
5586 bool back_val
= false;
5588 if (!is_constant_array_expr (array
)
5589 || !gfc_is_constant_expr (dim
))
5593 && !is_constant_array_expr (mask
)
5594 && mask
->expr_type
!= EXPR_CONSTANT
)
5599 if (gfc_extract_int (kind
, &ikind
, -1))
5603 ikind
= gfc_default_integer_kind
;
5607 if (back
->expr_type
!= EXPR_CONSTANT
)
5610 back_val
= back
->value
.logical
;
5620 extremum
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
5621 init_result_expr (extremum
, init_val
, array
);
5625 result
= transformational_result (array
, dim
, BT_INTEGER
,
5626 ikind
, &array
->where
);
5627 init_result_expr (result
, 0, array
);
5629 if (array
->rank
== 1)
5630 return simplify_minmaxloc_to_scalar (result
, array
, mask
, extremum
,
5633 return simplify_minmaxloc_to_array (result
, array
, dim
, mask
, extremum
,
5638 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5639 return simplify_minmaxloc_nodim (result
, extremum
, array
, mask
,
5645 gfc_simplify_minloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5648 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, -1);
5652 gfc_simplify_maxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5655 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, 1);
5658 /* Simplify findloc to scalar. Similar to
5659 simplify_minmaxloc_to_scalar. */
5662 simplify_findloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5663 gfc_expr
*mask
, int back_val
)
5666 gfc_constructor
*array_ctor
, *mask_ctor
;
5669 mpz_set_si (result
->value
.integer
, 0);
5671 /* Shortcut for constant .FALSE. MASK. */
5673 && mask
->expr_type
== EXPR_CONSTANT
5674 && !mask
->value
.logical
)
5677 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5678 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5679 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5683 mpz_init_set_si (count
, 0);
5686 mpz_add_ui (count
, count
, 1);
5687 a
= array_ctor
->expr
;
5688 array_ctor
= gfc_constructor_next (array_ctor
);
5689 /* A constant MASK equals .TRUE. here and can be ignored. */
5692 m
= mask_ctor
->expr
;
5693 mask_ctor
= gfc_constructor_next (mask_ctor
);
5694 if (!m
->value
.logical
)
5697 if (gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5699 /* We have a match. If BACK is true, continue so we find
5701 mpz_set (result
->value
.integer
, count
);
5710 /* Simplify findloc in the absence of a dim argument. Similar to
5711 simplify_minmaxloc_nodim. */
5714 simplify_findloc_nodim (gfc_expr
*result
, gfc_expr
*value
, gfc_expr
*array
,
5715 gfc_expr
*mask
, bool back_val
)
5717 ssize_t res
[GFC_MAX_DIMENSIONS
];
5719 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5720 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5721 sstride
[GFC_MAX_DIMENSIONS
];
5726 for (i
= 0; i
< array
->rank
; i
++)
5729 /* Shortcut for constant .FALSE. MASK. */
5731 && mask
->expr_type
== EXPR_CONSTANT
5732 && !mask
->value
.logical
)
5735 for (i
= 0; i
< array
->rank
; i
++)
5738 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5739 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5744 continue_loop
= true;
5745 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5746 if (mask
&& mask
->rank
> 0)
5747 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5751 /* Loop over the array elements (and mask), keeping track of
5752 the indices to return. */
5753 while (continue_loop
)
5757 a
= array_ctor
->expr
;
5760 m
= mask_ctor
->expr
;
5761 ma
= m
->value
.logical
;
5762 mask_ctor
= gfc_constructor_next (mask_ctor
);
5767 if (ma
&& gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5769 for (i
= 0; i
< array
->rank
; i
++)
5774 array_ctor
= gfc_constructor_next (array_ctor
);
5776 } while (count
[0] != extent
[0]);
5780 /* When we get to the end of a dimension, reset it and increment
5781 the next dimension. */
5784 if (n
>= array
->rank
)
5786 continue_loop
= false;
5791 } while (count
[n
] == extent
[n
]);
5795 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5796 for (i
= 0; i
< array
->rank
; i
++)
5799 r_expr
= result_ctor
->expr
;
5800 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5801 result_ctor
= gfc_constructor_next (result_ctor
);
5807 /* Simplify findloc to an array. Similar to
5808 simplify_minmaxloc_to_array. */
5811 simplify_findloc_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5812 gfc_expr
*dim
, gfc_expr
*mask
, bool back_val
)
5815 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5816 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5817 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5819 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5820 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5821 tmpstride
[GFC_MAX_DIMENSIONS
];
5823 /* Shortcut for constant .FALSE. MASK. */
5825 && mask
->expr_type
== EXPR_CONSTANT
5826 && !mask
->value
.logical
)
5829 /* Build an indexed table for array element expressions to minimize
5830 linked-list traversal. Masked elements are set to NULL. */
5831 gfc_array_size (array
, &size
);
5832 arraysize
= mpz_get_ui (size
);
5835 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5837 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5839 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5840 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5842 for (i
= 0; i
< arraysize
; ++i
)
5844 arrayvec
[i
] = array_ctor
->expr
;
5845 array_ctor
= gfc_constructor_next (array_ctor
);
5849 if (!mask_ctor
->expr
->value
.logical
)
5852 mask_ctor
= gfc_constructor_next (mask_ctor
);
5856 /* Same for the result expression. */
5857 gfc_array_size (result
, &size
);
5858 resultsize
= mpz_get_ui (size
);
5861 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5862 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5863 for (i
= 0; i
< resultsize
; ++i
)
5865 resultvec
[i
] = result_ctor
->expr
;
5866 result_ctor
= gfc_constructor_next (result_ctor
);
5869 gfc_extract_int (dim
, &dim_index
);
5871 dim_index
-= 1; /* Zero-base index. */
5875 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5878 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5881 dim_extent
= mpz_get_si (array
->shape
[i
]);
5882 dim_stride
= tmpstride
[i
];
5886 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5887 sstride
[n
] = tmpstride
[i
];
5888 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5892 done
= resultsize
<= 0;
5897 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5899 if (*src
&& gfc_compare_expr (*src
, value
, INTRINSIC_EQ
) == 0)
5901 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5912 while (!done
&& count
[n
] == extent
[n
])
5915 base
-= sstride
[n
] * extent
[n
];
5916 dest
-= dstride
[n
] * extent
[n
];
5919 if (n
< result
->rank
)
5921 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5922 times, we'd warn for the last iteration, because the
5923 array index will have already been incremented to the
5924 array sizes, and we can't tell that this must make
5925 the test against result->rank false, because ranks
5926 must not exceed GFC_MAX_DIMENSIONS. */
5927 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5938 /* Place updated expression in result constructor. */
5939 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5940 for (i
= 0; i
< resultsize
; ++i
)
5942 result_ctor
->expr
= resultvec
[i
];
5943 result_ctor
= gfc_constructor_next (result_ctor
);
5951 /* Simplify findloc. */
5954 gfc_simplify_findloc (gfc_expr
*array
, gfc_expr
*value
, gfc_expr
*dim
,
5955 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
5959 bool back_val
= false;
5961 if (!is_constant_array_expr (array
)
5962 || array
->shape
== NULL
5963 || !gfc_is_constant_expr (dim
))
5966 if (! gfc_is_constant_expr (value
))
5970 && !is_constant_array_expr (mask
)
5971 && mask
->expr_type
!= EXPR_CONSTANT
)
5976 if (gfc_extract_int (kind
, &ikind
, -1))
5980 ikind
= gfc_default_integer_kind
;
5984 if (back
->expr_type
!= EXPR_CONSTANT
)
5987 back_val
= back
->value
.logical
;
5992 result
= transformational_result (array
, dim
, BT_INTEGER
,
5993 ikind
, &array
->where
);
5994 init_result_expr (result
, 0, array
);
5996 if (array
->rank
== 1)
5997 return simplify_findloc_to_scalar (result
, array
, value
, mask
,
6000 return simplify_findloc_to_array (result
, array
, value
, dim
, mask
,
6005 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
6006 return simplify_findloc_nodim (result
, value
, array
, mask
, back_val
);
6012 gfc_simplify_maxexponent (gfc_expr
*x
)
6014 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
6015 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
6016 gfc_real_kinds
[i
].max_exponent
);
6021 gfc_simplify_minexponent (gfc_expr
*x
)
6023 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
6024 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
6025 gfc_real_kinds
[i
].min_exponent
);
6030 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
6035 /* First check p. */
6036 if (p
->expr_type
!= EXPR_CONSTANT
)
6039 /* p shall not be 0. */
6043 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
6045 gfc_error ("Argument %qs of MOD at %L shall not be zero",
6047 return &gfc_bad_expr
;
6051 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
6053 gfc_error ("Argument %qs of MOD at %L shall not be zero",
6055 return &gfc_bad_expr
;
6059 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6062 if (a
->expr_type
!= EXPR_CONSTANT
)
6065 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6066 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6068 if (a
->ts
.type
== BT_INTEGER
)
6069 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6072 gfc_set_model_kind (kind
);
6073 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6077 return range_check (result
, "MOD");
6082 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
6087 /* First check p. */
6088 if (p
->expr_type
!= EXPR_CONSTANT
)
6091 /* p shall not be 0. */
6095 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
6097 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6099 return &gfc_bad_expr
;
6103 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
6105 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6107 return &gfc_bad_expr
;
6111 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6114 if (a
->expr_type
!= EXPR_CONSTANT
)
6117 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6118 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6120 if (a
->ts
.type
== BT_INTEGER
)
6121 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6124 gfc_set_model_kind (kind
);
6125 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6127 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
6129 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
6130 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
6134 mpfr_copysign (result
->value
.real
, result
->value
.real
,
6135 p
->value
.real
, GFC_RND_MODE
);
6138 return range_check (result
, "MODULO");
6143 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
6146 mpfr_exp_t emin
, emax
;
6149 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
6152 result
= gfc_copy_expr (x
);
6154 /* Save current values of emin and emax. */
6155 emin
= mpfr_get_emin ();
6156 emax
= mpfr_get_emax ();
6158 /* Set emin and emax for the current model number. */
6159 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
6160 mpfr_set_emin ((mpfr_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
6161 mpfr_get_prec(result
->value
.real
) + 1);
6162 mpfr_set_emax ((mpfr_exp_t
) gfc_real_kinds
[kind
].max_exponent
);
6163 mpfr_check_range (result
->value
.real
, 0, MPFR_RNDU
);
6165 if (mpfr_sgn (s
->value
.real
) > 0)
6167 mpfr_nextabove (result
->value
.real
);
6168 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDU
);
6172 mpfr_nextbelow (result
->value
.real
);
6173 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDD
);
6176 mpfr_set_emin (emin
);
6177 mpfr_set_emax (emax
);
6179 /* Only NaN can occur. Do not use range check as it gives an
6180 error for denormal numbers. */
6181 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
6183 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
6184 gfc_free_expr (result
);
6185 return &gfc_bad_expr
;
6193 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
6195 gfc_expr
*itrunc
, *result
;
6198 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
6200 return &gfc_bad_expr
;
6202 if (e
->expr_type
!= EXPR_CONSTANT
)
6205 itrunc
= gfc_copy_expr (e
);
6206 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
6208 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
6209 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
6211 gfc_free_expr (itrunc
);
6213 return range_check (result
, name
);
6218 gfc_simplify_new_line (gfc_expr
*e
)
6222 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
6223 result
->value
.character
.string
[0] = '\n';
6230 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
6232 return simplify_nint ("NINT", e
, k
);
6237 gfc_simplify_idnint (gfc_expr
*e
)
6239 return simplify_nint ("IDNINT", e
, NULL
);
6242 static int norm2_scale
;
6245 norm2_add_squared (gfc_expr
*result
, gfc_expr
*e
)
6249 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6250 gcc_assert (result
->ts
.type
== BT_REAL
6251 && result
->expr_type
== EXPR_CONSTANT
);
6253 gfc_set_model_kind (result
->ts
.kind
);
6254 int index
= gfc_validate_kind (BT_REAL
, result
->ts
.kind
, false);
6256 if (mpfr_regular_p (result
->value
.real
))
6258 exp
= mpfr_get_exp (result
->value
.real
);
6259 /* If result is getting close to overflowing, scale down. */
6260 if (exp
>= gfc_real_kinds
[index
].max_exponent
- 4
6261 && norm2_scale
<= gfc_real_kinds
[index
].max_exponent
- 2)
6264 mpfr_div_ui (result
->value
.real
, result
->value
.real
, 16,
6270 if (mpfr_regular_p (e
->value
.real
))
6272 exp
= mpfr_get_exp (e
->value
.real
);
6273 /* If e**2 would overflow or close to overflowing, scale down. */
6274 if (exp
- norm2_scale
>= gfc_real_kinds
[index
].max_exponent
/ 2 - 2)
6276 int new_scale
= gfc_real_kinds
[index
].max_exponent
/ 2 + 4;
6277 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6278 mpfr_set_exp (tmp
, new_scale
- norm2_scale
);
6279 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6280 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6281 norm2_scale
= new_scale
;
6286 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6287 mpfr_set_exp (tmp
, norm2_scale
);
6288 mpfr_div (tmp
, e
->value
.real
, tmp
, GFC_RND_MODE
);
6291 mpfr_set (tmp
, e
->value
.real
, GFC_RND_MODE
);
6292 mpfr_pow_ui (tmp
, tmp
, 2, GFC_RND_MODE
);
6293 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
6302 norm2_do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
6304 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6305 gcc_assert (result
->ts
.type
== BT_REAL
6306 && result
->expr_type
== EXPR_CONSTANT
);
6309 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6310 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6311 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6315 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6316 mpfr_set_exp (tmp
, norm2_scale
);
6317 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6327 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
6332 size_zero
= gfc_is_size_zero_array (e
);
6334 if (!(is_constant_array_expr (e
) || size_zero
)
6335 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
6338 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6339 init_result_expr (result
, 0, NULL
);
6345 if (!dim
|| e
->rank
== 1)
6347 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
6349 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6350 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6354 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6355 mpfr_set_exp (tmp
, norm2_scale
);
6356 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6362 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
6371 gfc_simplify_not (gfc_expr
*e
)
6375 if (e
->expr_type
!= EXPR_CONSTANT
)
6378 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6379 mpz_com (result
->value
.integer
, e
->value
.integer
);
6381 return range_check (result
, "NOT");
6386 gfc_simplify_null (gfc_expr
*mold
)
6392 result
= gfc_copy_expr (mold
);
6393 result
->expr_type
= EXPR_NULL
;
6396 result
= gfc_get_null_expr (NULL
);
6403 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
6407 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6409 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6410 return &gfc_bad_expr
;
6413 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6416 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
6419 /* FIXME: gfc_current_locus is wrong. */
6420 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6421 &gfc_current_locus
);
6423 if (failed
&& failed
->value
.logical
!= 0)
6424 mpz_set_si (result
->value
.integer
, 0);
6426 mpz_set_si (result
->value
.integer
, 1);
6433 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
6438 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6441 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6446 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6447 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6448 return range_check (result
, "OR");
6451 return gfc_get_logical_expr (kind
, &x
->where
,
6452 x
->value
.logical
|| y
->value
.logical
);
6460 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
6463 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
6465 if (!is_constant_array_expr (array
)
6466 || !is_constant_array_expr (vector
)
6467 || (!gfc_is_constant_expr (mask
)
6468 && !is_constant_array_expr (mask
)))
6471 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
6472 if (array
->ts
.type
== BT_DERIVED
)
6473 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
6475 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
6476 vector_ctor
= vector
6477 ? gfc_constructor_first (vector
->value
.constructor
)
6480 if (mask
->expr_type
== EXPR_CONSTANT
6481 && mask
->value
.logical
)
6483 /* Copy all elements of ARRAY to RESULT. */
6486 gfc_constructor_append_expr (&result
->value
.constructor
,
6487 gfc_copy_expr (array_ctor
->expr
),
6490 array_ctor
= gfc_constructor_next (array_ctor
);
6491 vector_ctor
= gfc_constructor_next (vector_ctor
);
6494 else if (mask
->expr_type
== EXPR_ARRAY
)
6496 /* Copy only those elements of ARRAY to RESULT whose
6497 MASK equals .TRUE.. */
6498 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6499 while (mask_ctor
&& array_ctor
)
6501 if (mask_ctor
->expr
->value
.logical
)
6503 gfc_constructor_append_expr (&result
->value
.constructor
,
6504 gfc_copy_expr (array_ctor
->expr
),
6506 vector_ctor
= gfc_constructor_next (vector_ctor
);
6509 array_ctor
= gfc_constructor_next (array_ctor
);
6510 mask_ctor
= gfc_constructor_next (mask_ctor
);
6514 /* Append any left-over elements from VECTOR to RESULT. */
6517 gfc_constructor_append_expr (&result
->value
.constructor
,
6518 gfc_copy_expr (vector_ctor
->expr
),
6520 vector_ctor
= gfc_constructor_next (vector_ctor
);
6523 result
->shape
= gfc_get_shape (1);
6524 gfc_array_size (result
, &result
->shape
[0]);
6526 if (array
->ts
.type
== BT_CHARACTER
)
6527 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
6534 do_xor (gfc_expr
*result
, gfc_expr
*e
)
6536 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
6537 gcc_assert (result
->ts
.type
== BT_LOGICAL
6538 && result
->expr_type
== EXPR_CONSTANT
);
6540 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
6546 gfc_simplify_is_contiguous (gfc_expr
*array
)
6548 if (gfc_is_simply_contiguous (array
, false, true))
6549 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 1);
6551 if (gfc_is_not_contiguous (array
))
6552 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 0);
6559 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
6561 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
6566 gfc_simplify_popcnt (gfc_expr
*e
)
6571 if (e
->expr_type
!= EXPR_CONSTANT
)
6574 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6576 /* Convert argument to unsigned, then count the '1' bits. */
6577 mpz_init_set (x
, e
->value
.integer
);
6578 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
6579 res
= mpz_popcount (x
);
6582 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
6587 gfc_simplify_poppar (gfc_expr
*e
)
6592 if (e
->expr_type
!= EXPR_CONSTANT
)
6595 popcnt
= gfc_simplify_popcnt (e
);
6596 gcc_assert (popcnt
);
6598 bool fail
= gfc_extract_int (popcnt
, &i
);
6601 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
6606 gfc_simplify_precision (gfc_expr
*e
)
6608 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6609 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
6610 gfc_real_kinds
[i
].precision
);
6615 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6617 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
6622 gfc_simplify_radix (gfc_expr
*e
)
6625 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6630 i
= gfc_integer_kinds
[i
].radix
;
6634 i
= gfc_real_kinds
[i
].radix
;
6641 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6646 gfc_simplify_range (gfc_expr
*e
)
6649 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6654 i
= gfc_integer_kinds
[i
].range
;
6659 i
= gfc_real_kinds
[i
].range
;
6666 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6671 gfc_simplify_rank (gfc_expr
*e
)
6677 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
6682 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
6684 gfc_expr
*result
= NULL
;
6685 int kind
, tmp1
, tmp2
;
6687 /* Convert BOZ to real, and return without range checking. */
6688 if (e
->ts
.type
== BT_BOZ
)
6690 /* Determine kind for conversion of the BOZ. */
6692 gfc_extract_int (k
, &kind
);
6694 kind
= gfc_default_real_kind
;
6696 if (!gfc_boz2real (e
, kind
))
6698 result
= gfc_copy_expr (e
);
6702 if (e
->ts
.type
== BT_COMPLEX
)
6703 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
6705 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
6708 return &gfc_bad_expr
;
6710 if (e
->expr_type
!= EXPR_CONSTANT
)
6713 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
6715 tmp1
= warn_conversion
;
6716 tmp2
= warn_conversion_extra
;
6717 warn_conversion
= warn_conversion_extra
= 0;
6719 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
6721 warn_conversion
= tmp1
;
6722 warn_conversion_extra
= tmp2
;
6724 if (result
== &gfc_bad_expr
)
6725 return &gfc_bad_expr
;
6727 return range_check (result
, "REAL");
6732 gfc_simplify_realpart (gfc_expr
*e
)
6736 if (e
->expr_type
!= EXPR_CONSTANT
)
6739 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6740 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
6742 return range_check (result
, "REALPART");
6746 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
6751 bool have_length
= false;
6753 /* If NCOPIES isn't a constant, there's nothing we can do. */
6754 if (n
->expr_type
!= EXPR_CONSTANT
)
6757 /* If NCOPIES is negative, it's an error. */
6758 if (mpz_sgn (n
->value
.integer
) < 0)
6760 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6762 return &gfc_bad_expr
;
6765 /* If we don't know the character length, we can do no more. */
6766 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
6767 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6769 len
= gfc_mpz_get_hwi (e
->ts
.u
.cl
->length
->value
.integer
);
6772 else if (e
->expr_type
== EXPR_CONSTANT
6773 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
6775 len
= e
->value
.character
.length
;
6780 /* If the source length is 0, any value of NCOPIES is valid
6781 and everything behaves as if NCOPIES == 0. */
6784 mpz_set_ui (ncopies
, 0);
6786 mpz_set (ncopies
, n
->value
.integer
);
6788 /* Check that NCOPIES isn't too large. */
6794 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6796 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6800 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
6801 e
->ts
.u
.cl
->length
->value
.integer
);
6806 gfc_mpz_set_hwi (mlen
, len
);
6807 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
6811 /* The check itself. */
6812 if (mpz_cmp (ncopies
, max
) > 0)
6815 mpz_clear (ncopies
);
6816 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6818 return &gfc_bad_expr
;
6823 mpz_clear (ncopies
);
6825 /* For further simplification, we need the character string to be
6827 if (e
->expr_type
!= EXPR_CONSTANT
)
6832 (e
->ts
.u
.cl
->length
&&
6833 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
) != 0))
6835 bool fail
= gfc_extract_hwi (n
, &ncop
);
6842 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
6844 len
= e
->value
.character
.length
;
6845 gfc_charlen_t nlen
= ncop
* len
;
6847 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6848 (2**28 elements * 4 bytes (wide chars) per element) defer to
6849 runtime instead of consuming (unbounded) memory and CPU at
6851 if (nlen
> 268435456)
6853 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6854 " deferred to runtime, expect bugs", &e
->where
);
6858 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
6859 for (size_t i
= 0; i
< (size_t) ncop
; i
++)
6860 for (size_t j
= 0; j
< (size_t) len
; j
++)
6861 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
6863 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
6868 /* This one is a bear, but mainly has to do with shuffling elements. */
6871 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
6872 gfc_expr
*pad
, gfc_expr
*order_exp
)
6874 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
6875 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
6879 gfc_expr
*e
, *result
;
6880 bool zerosize
= false;
6882 /* Check that argument expression types are OK. */
6883 if (!is_constant_array_expr (source
)
6884 || !is_constant_array_expr (shape_exp
)
6885 || !is_constant_array_expr (pad
)
6886 || !is_constant_array_expr (order_exp
))
6889 if (source
->shape
== NULL
)
6892 /* Proceed with simplification, unpacking the array. */
6897 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
6902 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
6906 gfc_extract_int (e
, &shape
[rank
]);
6908 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
6909 if (shape
[rank
] < 0)
6911 gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
6912 "negative value %d for dimension %d",
6913 &shape_exp
->where
, shape
[rank
], rank
+1);
6915 return &gfc_bad_expr
;
6921 gcc_assert (rank
> 0);
6923 /* Now unpack the order array if present. */
6924 if (order_exp
== NULL
)
6926 for (i
= 0; i
< rank
; i
++)
6932 int order_size
, shape_size
;
6934 if (order_exp
->rank
!= shape_exp
->rank
)
6936 gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
6937 &order_exp
->where
, &shape_exp
->where
);
6939 return &gfc_bad_expr
;
6942 gfc_array_size (shape_exp
, &size
);
6943 shape_size
= mpz_get_ui (size
);
6945 gfc_array_size (order_exp
, &size
);
6946 order_size
= mpz_get_ui (size
);
6948 if (order_size
!= shape_size
)
6950 gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
6951 &order_exp
->where
, &shape_exp
->where
);
6953 return &gfc_bad_expr
;
6956 for (i
= 0; i
< rank
; i
++)
6958 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
6961 gfc_extract_int (e
, &order
[i
]);
6963 if (order
[i
] < 1 || order
[i
] > rank
)
6965 gfc_error ("Element with a value of %d in ORDER at %L must be "
6966 "in the range [1, ..., %d] for the RESHAPE intrinsic "
6967 "near %L", order
[i
], &order_exp
->where
, rank
,
6970 return &gfc_bad_expr
;
6974 if (x
[order
[i
]] != 0)
6976 gfc_error ("ORDER at %L is not a permutation of the size of "
6977 "SHAPE at %L", &order_exp
->where
, &shape_exp
->where
);
6979 return &gfc_bad_expr
;
6985 /* Count the elements in the source and padding arrays. */
6990 gfc_array_size (pad
, &size
);
6991 npad
= mpz_get_ui (size
);
6995 gfc_array_size (source
, &size
);
6996 nsource
= mpz_get_ui (size
);
6999 /* If it weren't for that pesky permutation we could just loop
7000 through the source and round out any shortage with pad elements.
7001 But no, someone just had to have the compiler do something the
7002 user should be doing. */
7004 for (i
= 0; i
< rank
; i
++)
7007 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7009 if (source
->ts
.type
== BT_DERIVED
)
7010 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7011 if (source
->ts
.type
== BT_CHARACTER
&& result
->ts
.u
.cl
== NULL
)
7012 result
->ts
= source
->ts
;
7013 result
->rank
= rank
;
7014 result
->shape
= gfc_get_shape (rank
);
7015 for (i
= 0; i
< rank
; i
++)
7017 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
7025 while (nsource
> 0 || npad
> 0)
7027 /* Figure out which element to extract. */
7028 mpz_set_ui (index
, 0);
7030 for (i
= rank
- 1; i
>= 0; i
--)
7032 mpz_add_ui (index
, index
, x
[order
[i
]]);
7034 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
7037 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
7038 gfc_internal_error ("Reshaped array too large at %C");
7040 j
= mpz_get_ui (index
);
7043 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
7050 gfc_error ("Without padding, there are not enough elements "
7051 "in the intrinsic RESHAPE source at %L to match "
7052 "the shape", &source
->where
);
7053 gfc_free_expr (result
);
7058 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
7062 gfc_constructor_append_expr (&result
->value
.constructor
,
7063 gfc_copy_expr (e
), &e
->where
);
7065 /* Calculate the next element. */
7069 if (++x
[i
] < shape
[i
])
7087 gfc_simplify_rrspacing (gfc_expr
*x
)
7093 if (x
->expr_type
!= EXPR_CONSTANT
)
7096 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7098 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7100 /* RRSPACING(+/- 0.0) = 0.0 */
7101 if (mpfr_zero_p (x
->value
.real
))
7103 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7107 /* RRSPACING(inf) = NaN */
7108 if (mpfr_inf_p (x
->value
.real
))
7110 mpfr_set_nan (result
->value
.real
);
7114 /* RRSPACING(NaN) = same NaN */
7115 if (mpfr_nan_p (x
->value
.real
))
7117 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7121 /* | x * 2**(-e) | * 2**p. */
7122 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7123 e
= - (long int) mpfr_get_exp (x
->value
.real
);
7124 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
7126 p
= (long int) gfc_real_kinds
[i
].digits
;
7127 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
7129 return range_check (result
, "RRSPACING");
7134 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
7136 int k
, neg_flag
, power
, exp_range
;
7137 mpfr_t scale
, radix
;
7140 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7143 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7145 if (mpfr_zero_p (x
->value
.real
))
7147 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7151 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
7153 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
7155 /* This check filters out values of i that would overflow an int. */
7156 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
7157 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
7159 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
7160 gfc_free_expr (result
);
7161 return &gfc_bad_expr
;
7164 /* Compute scale = radix ** power. */
7165 power
= mpz_get_si (i
->value
.integer
);
7175 gfc_set_model_kind (x
->ts
.kind
);
7178 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
7179 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
7182 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7184 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7186 mpfr_clears (scale
, radix
, NULL
);
7188 return range_check (result
, "SCALE");
7192 /* Variants of strspn and strcspn that operate on wide characters. */
7195 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7198 const gfc_char_t
*c
;
7202 for (c
= s2
; *c
; c
++)
7216 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7219 const gfc_char_t
*c
;
7223 for (c
= s2
; *c
; c
++)
7238 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
7243 size_t indx
, len
, lenc
;
7244 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
7247 return &gfc_bad_expr
;
7249 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
7250 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
7253 if (b
!= NULL
&& b
->value
.logical
!= 0)
7258 len
= e
->value
.character
.length
;
7259 lenc
= c
->value
.character
.length
;
7261 if (len
== 0 || lenc
== 0)
7269 indx
= wide_strcspn (e
->value
.character
.string
,
7270 c
->value
.character
.string
) + 1;
7275 for (indx
= len
; indx
> 0; indx
--)
7277 for (i
= 0; i
< lenc
; i
++)
7279 if (c
->value
.character
.string
[i
]
7280 == e
->value
.character
.string
[indx
- 1])
7288 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
7289 return range_check (result
, "SCAN");
7294 gfc_simplify_selected_char_kind (gfc_expr
*e
)
7298 if (e
->expr_type
!= EXPR_CONSTANT
)
7301 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
7302 || gfc_compare_with_Cstring (e
, "default", false) == 0)
7304 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
7309 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7314 gfc_simplify_selected_int_kind (gfc_expr
*e
)
7318 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
))
7323 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
7324 if (gfc_integer_kinds
[i
].range
>= range
7325 && gfc_integer_kinds
[i
].kind
< kind
)
7326 kind
= gfc_integer_kinds
[i
].kind
;
7328 if (kind
== INT_MAX
)
7331 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7336 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
7338 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
7340 locus
*loc
= &gfc_current_locus
;
7346 if (p
->expr_type
!= EXPR_CONSTANT
7347 || gfc_extract_int (p
, &precision
))
7356 if (q
->expr_type
!= EXPR_CONSTANT
7357 || gfc_extract_int (q
, &range
))
7368 if (rdx
->expr_type
!= EXPR_CONSTANT
7369 || gfc_extract_int (rdx
, &radix
))
7377 found_precision
= 0;
7381 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
7383 if (gfc_real_kinds
[i
].precision
>= precision
)
7384 found_precision
= 1;
7386 if (gfc_real_kinds
[i
].range
>= range
)
7389 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7392 if (gfc_real_kinds
[i
].precision
>= precision
7393 && gfc_real_kinds
[i
].range
>= range
7394 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7395 && gfc_real_kinds
[i
].kind
< kind
)
7396 kind
= gfc_real_kinds
[i
].kind
;
7399 if (kind
== INT_MAX
)
7401 if (found_radix
&& found_range
&& !found_precision
)
7403 else if (found_radix
&& found_precision
&& !found_range
)
7405 else if (found_radix
&& !found_precision
&& !found_range
)
7407 else if (found_radix
)
7413 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
7418 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
7421 mpfr_t exp
, absv
, log2
, pow2
, frac
;
7424 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7427 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7429 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7430 SET_EXPONENT (NaN) = same NaN */
7431 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
7433 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7437 /* SET_EXPONENT (inf) = NaN */
7438 if (mpfr_inf_p (x
->value
.real
))
7440 mpfr_set_nan (result
->value
.real
);
7444 gfc_set_model_kind (x
->ts
.kind
);
7451 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
7452 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
7454 mpfr_floor (log2
, log2
);
7455 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
7457 /* Old exponent value, and fraction. */
7458 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
7460 mpfr_div (frac
, x
->value
.real
, pow2
, GFC_RND_MODE
);
7463 exp2
= mpz_get_si (i
->value
.integer
);
7464 mpfr_mul_2si (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
7466 mpfr_clears (absv
, log2
, exp
, pow2
, frac
, NULL
);
7468 return range_check (result
, "SET_EXPONENT");
7473 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
7475 mpz_t shape
[GFC_MAX_DIMENSIONS
];
7476 gfc_expr
*result
, *e
, *f
;
7480 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
7482 if (source
->rank
== -1)
7485 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
7486 result
->shape
= gfc_get_shape (1);
7487 mpz_init (result
->shape
[0]);
7489 if (source
->rank
== 0)
7492 if (source
->expr_type
== EXPR_VARIABLE
)
7494 ar
= gfc_find_array_ref (source
);
7495 t
= gfc_array_ref_shape (ar
, shape
);
7497 else if (source
->shape
)
7500 for (n
= 0; n
< source
->rank
; n
++)
7502 mpz_init (shape
[n
]);
7503 mpz_set (shape
[n
], source
->shape
[n
]);
7509 for (n
= 0; n
< source
->rank
; n
++)
7511 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
7514 mpz_set (e
->value
.integer
, shape
[n
]);
7517 mpz_set_ui (e
->value
.integer
, n
+ 1);
7519 f
= simplify_size (source
, e
, k
);
7523 gfc_free_expr (result
);
7530 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
7532 gfc_free_expr (result
);
7534 gfc_clear_shape (shape
, source
->rank
);
7535 return &gfc_bad_expr
;
7538 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
7542 gfc_clear_shape (shape
, source
->rank
);
7544 mpz_set_si (result
->shape
[0], source
->rank
);
7551 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
7554 gfc_expr
*return_value
;
7558 /* For unary operations, the size of the result is given by the size
7559 of the operand. For binary ones, it's the size of the first operand
7560 unless it is scalar, then it is the size of the second. */
7561 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
7563 gfc_expr
* replacement
;
7564 gfc_expr
* simplified
;
7566 switch (array
->value
.op
.op
)
7568 /* Unary operations. */
7570 case INTRINSIC_UPLUS
:
7571 case INTRINSIC_UMINUS
:
7572 case INTRINSIC_PARENTHESES
:
7573 replacement
= array
->value
.op
.op1
;
7576 /* Binary operations. If any one of the operands is scalar, take
7577 the other one's size. If both of them are arrays, it does not
7578 matter -- try to find one with known shape, if possible. */
7580 if (array
->value
.op
.op1
->rank
== 0)
7581 replacement
= array
->value
.op
.op2
;
7582 else if (array
->value
.op
.op2
->rank
== 0)
7583 replacement
= array
->value
.op
.op1
;
7586 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
7590 replacement
= array
->value
.op
.op2
;
7595 /* Try to reduce it directly if possible. */
7596 simplified
= simplify_size (replacement
, dim
, k
);
7598 /* Otherwise, we build a new SIZE call. This is hopefully at least
7599 simpler than the original one. */
7602 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
7603 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
7604 GFC_ISYM_SIZE
, "size",
7606 gfc_copy_expr (replacement
),
7607 gfc_copy_expr (dim
),
7613 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
7614 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
7615 && !gfc_resolve_array_spec (ref
->u
.ar
.as
, 0))
7620 if (!gfc_array_size (array
, &size
))
7625 if (dim
->expr_type
!= EXPR_CONSTANT
)
7628 if (array
->rank
== -1)
7631 d
= mpz_get_si (dim
->value
.integer
) - 1;
7632 if (d
< 0 || d
> array
->rank
- 1)
7634 gfc_error ("DIM argument (%d) to intrinsic SIZE at %L out of range "
7635 "(1:%d)", d
+1, &array
->where
, array
->rank
);
7636 return &gfc_bad_expr
;
7639 if (!gfc_array_dimen_size (array
, d
, &size
))
7643 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
7644 mpz_set (return_value
->value
.integer
, size
);
7647 return return_value
;
7652 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
7655 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
7658 return &gfc_bad_expr
;
7660 result
= simplify_size (array
, dim
, k
);
7661 if (result
== NULL
|| result
== &gfc_bad_expr
)
7664 return range_check (result
, "SIZE");
7668 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
7669 multiplied by the array size. */
7672 gfc_simplify_sizeof (gfc_expr
*x
)
7674 gfc_expr
*result
= NULL
;
7678 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7681 if (x
->ts
.type
== BT_CHARACTER
7682 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7683 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7686 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
7687 && !gfc_array_size (x
, &array_size
))
7690 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
7692 gfc_target_expr_size (x
, &res_size
);
7693 mpz_set_si (result
->value
.integer
, res_size
);
7699 /* STORAGE_SIZE returns the size in bits of a single array element. */
7702 gfc_simplify_storage_size (gfc_expr
*x
,
7705 gfc_expr
*result
= NULL
;
7709 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7712 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
7713 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7714 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7717 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
7719 return &gfc_bad_expr
;
7721 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
7723 gfc_element_size (x
, &siz
);
7724 mpz_set_si (result
->value
.integer
, siz
);
7725 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
7727 return range_check (result
, "STORAGE_SIZE");
7732 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
7736 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
7739 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7744 mpz_abs (result
->value
.integer
, x
->value
.integer
);
7745 if (mpz_sgn (y
->value
.integer
) < 0)
7746 mpz_neg (result
->value
.integer
, result
->value
.integer
);
7751 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
7754 mpfr_setsign (result
->value
.real
, x
->value
.real
,
7755 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
7759 gfc_internal_error ("Bad type in gfc_simplify_sign");
7767 gfc_simplify_sin (gfc_expr
*x
)
7771 if (x
->expr_type
!= EXPR_CONSTANT
)
7774 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7779 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7783 gfc_set_model (x
->value
.real
);
7784 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7788 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
7791 return range_check (result
, "SIN");
7796 gfc_simplify_sinh (gfc_expr
*x
)
7800 if (x
->expr_type
!= EXPR_CONSTANT
)
7803 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7808 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7812 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7819 return range_check (result
, "SINH");
7823 /* The argument is always a double precision real that is converted to
7824 single precision. TODO: Rounding! */
7827 gfc_simplify_sngl (gfc_expr
*a
)
7832 if (a
->expr_type
!= EXPR_CONSTANT
)
7835 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
7837 tmp1
= warn_conversion
;
7838 tmp2
= warn_conversion_extra
;
7839 warn_conversion
= warn_conversion_extra
= 0;
7841 result
= gfc_real2real (a
, gfc_default_real_kind
);
7843 warn_conversion
= tmp1
;
7844 warn_conversion_extra
= tmp2
;
7846 return range_check (result
, "SNGL");
7851 gfc_simplify_spacing (gfc_expr
*x
)
7857 if (x
->expr_type
!= EXPR_CONSTANT
)
7860 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7861 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7863 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
7864 if (mpfr_zero_p (x
->value
.real
))
7866 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
7870 /* SPACING(inf) = NaN */
7871 if (mpfr_inf_p (x
->value
.real
))
7873 mpfr_set_nan (result
->value
.real
);
7877 /* SPACING(NaN) = same NaN */
7878 if (mpfr_nan_p (x
->value
.real
))
7880 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7884 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
7885 are the radix, exponent of x, and precision. This excludes the
7886 possibility of subnormal numbers. Fortran 2003 states the result is
7887 b**max(e - p, emin - 1). */
7889 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
7890 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
7891 en
= en
> ep
? en
: ep
;
7893 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
7894 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
7896 return range_check (result
, "SPACING");
7901 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
7903 gfc_expr
*result
= NULL
;
7904 int nelem
, i
, j
, dim
, ncopies
;
7907 if ((!gfc_is_constant_expr (source
)
7908 && !is_constant_array_expr (source
))
7909 || !gfc_is_constant_expr (dim_expr
)
7910 || !gfc_is_constant_expr (ncopies_expr
))
7913 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
7914 gfc_extract_int (dim_expr
, &dim
);
7915 dim
-= 1; /* zero-base DIM */
7917 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
7918 gfc_extract_int (ncopies_expr
, &ncopies
);
7919 ncopies
= MAX (ncopies
, 0);
7921 /* Do not allow the array size to exceed the limit for an array
7923 if (source
->expr_type
== EXPR_ARRAY
)
7925 if (!gfc_array_size (source
, &size
))
7926 gfc_internal_error ("Failure getting length of a constant array.");
7929 mpz_init_set_ui (size
, 1);
7931 nelem
= mpz_get_si (size
) * ncopies
;
7932 if (nelem
> flag_max_array_constructor
)
7934 if (gfc_init_expr_flag
)
7936 gfc_error ("The number of elements (%d) in the array constructor "
7937 "at %L requires an increase of the allowed %d upper "
7938 "limit. See %<-fmax-array-constructor%> option.",
7939 nelem
, &source
->where
, flag_max_array_constructor
);
7940 return &gfc_bad_expr
;
7946 if (source
->expr_type
== EXPR_CONSTANT
7947 || source
->expr_type
== EXPR_STRUCTURE
)
7949 gcc_assert (dim
== 0);
7951 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7953 if (source
->ts
.type
== BT_DERIVED
)
7954 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7956 result
->shape
= gfc_get_shape (result
->rank
);
7957 mpz_init_set_si (result
->shape
[0], ncopies
);
7959 for (i
= 0; i
< ncopies
; ++i
)
7960 gfc_constructor_append_expr (&result
->value
.constructor
,
7961 gfc_copy_expr (source
), NULL
);
7963 else if (source
->expr_type
== EXPR_ARRAY
)
7965 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
7966 gfc_constructor
*source_ctor
;
7968 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
7969 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
7971 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7973 if (source
->ts
.type
== BT_DERIVED
)
7974 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7975 result
->rank
= source
->rank
+ 1;
7976 result
->shape
= gfc_get_shape (result
->rank
);
7978 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
7981 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
7983 mpz_init_set_si (result
->shape
[i
], ncopies
);
7985 extent
[i
] = mpz_get_si (result
->shape
[i
]);
7986 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
7990 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
7991 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
7993 for (i
= 0; i
< ncopies
; ++i
)
7994 gfc_constructor_insert_expr (&result
->value
.constructor
,
7995 gfc_copy_expr (source_ctor
->expr
),
7996 NULL
, offset
+ i
* rstride
[dim
]);
7998 offset
+= (dim
== 0 ? ncopies
: 1);
8003 gfc_error ("Simplification of SPREAD at %C not yet implemented");
8004 return &gfc_bad_expr
;
8007 if (source
->ts
.type
== BT_CHARACTER
)
8008 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
8015 gfc_simplify_sqrt (gfc_expr
*e
)
8017 gfc_expr
*result
= NULL
;
8019 if (e
->expr_type
!= EXPR_CONSTANT
)
8025 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
8027 gfc_error ("Argument of SQRT at %L has a negative value",
8029 return &gfc_bad_expr
;
8031 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
8032 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
8036 gfc_set_model (e
->value
.real
);
8038 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
8039 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
8043 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
8046 return range_check (result
, "SQRT");
8051 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
8053 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
8057 /* Simplify COTAN(X) where X has the unit of radian. */
8060 gfc_simplify_cotan (gfc_expr
*x
)
8065 if (x
->expr_type
!= EXPR_CONSTANT
)
8068 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8073 mpfr_cot (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8077 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
8078 val
= &result
->value
.complex;
8079 mpc_init2 (swp
, mpfr_get_default_prec ());
8080 mpc_sin_cos (*val
, swp
, x
->value
.complex, GFC_MPC_RND_MODE
,
8082 mpc_div (*val
, swp
, *val
, GFC_MPC_RND_MODE
);
8090 return range_check (result
, "COTAN");
8095 gfc_simplify_tan (gfc_expr
*x
)
8099 if (x
->expr_type
!= EXPR_CONSTANT
)
8102 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8107 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8111 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8118 return range_check (result
, "TAN");
8123 gfc_simplify_tanh (gfc_expr
*x
)
8127 if (x
->expr_type
!= EXPR_CONSTANT
)
8130 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8135 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8139 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8146 return range_check (result
, "TANH");
8151 gfc_simplify_tiny (gfc_expr
*e
)
8156 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
8158 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
8159 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
8166 gfc_simplify_trailz (gfc_expr
*e
)
8168 unsigned long tz
, bs
;
8171 if (e
->expr_type
!= EXPR_CONSTANT
)
8174 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
8175 bs
= gfc_integer_kinds
[i
].bit_size
;
8176 tz
= mpz_scan1 (e
->value
.integer
, 0);
8178 return gfc_get_int_expr (gfc_default_integer_kind
,
8179 &e
->where
, MIN (tz
, bs
));
8184 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
8187 gfc_expr
*mold_element
;
8192 unsigned char *buffer
;
8193 size_t result_length
;
8195 if (!gfc_is_constant_expr (source
) || !gfc_is_constant_expr (size
))
8198 if (!gfc_resolve_expr (mold
))
8200 if (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
8203 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
8204 &result_size
, &result_length
))
8207 /* Calculate the size of the source. */
8208 if (source
->expr_type
== EXPR_ARRAY
&& !gfc_array_size (source
, &tmp
))
8209 gfc_internal_error ("Failure getting length of a constant array.");
8211 /* Create an empty new expression with the appropriate characteristics. */
8212 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
8214 result
->ts
= mold
->ts
;
8216 mold_element
= (mold
->expr_type
== EXPR_ARRAY
&& mold
->value
.constructor
)
8217 ? gfc_constructor_first (mold
->value
.constructor
)->expr
8220 /* Set result character length, if needed. Note that this needs to be
8221 set even for array expressions, in order to pass this information into
8222 gfc_target_interpret_expr. */
8223 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
8225 result
->value
.character
.length
= mold_element
->value
.character
.length
;
8227 /* Let the typespec of the result inherit the string length.
8228 This is crucial if a resulting array has size zero. */
8229 if (mold_element
->ts
.u
.cl
->length
)
8230 result
->ts
.u
.cl
->length
= gfc_copy_expr (mold_element
->ts
.u
.cl
->length
);
8232 result
->ts
.u
.cl
->length
=
8233 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8234 mold_element
->value
.character
.length
);
8237 /* Set the number of elements in the result, and determine its size. */
8239 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
8241 result
->expr_type
= EXPR_ARRAY
;
8243 result
->shape
= gfc_get_shape (1);
8244 mpz_init_set_ui (result
->shape
[0], result_length
);
8249 /* Allocate the buffer to store the binary version of the source. */
8250 buffer_size
= MAX (source_size
, result_size
);
8251 buffer
= (unsigned char*)alloca (buffer_size
);
8252 memset (buffer
, 0, buffer_size
);
8254 /* Now write source to the buffer. */
8255 gfc_target_encode_expr (source
, buffer
, buffer_size
);
8257 /* And read the buffer back into the new expression. */
8258 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
8265 gfc_simplify_transpose (gfc_expr
*matrix
)
8267 int row
, matrix_rows
, col
, matrix_cols
;
8270 if (!is_constant_array_expr (matrix
))
8273 gcc_assert (matrix
->rank
== 2);
8275 if (matrix
->shape
== NULL
)
8278 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
8281 result
->shape
= gfc_get_shape (result
->rank
);
8282 mpz_init_set (result
->shape
[0], matrix
->shape
[1]);
8283 mpz_init_set (result
->shape
[1], matrix
->shape
[0]);
8285 if (matrix
->ts
.type
== BT_CHARACTER
)
8286 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
8287 else if (matrix
->ts
.type
== BT_DERIVED
)
8288 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
8290 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
8291 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
8292 for (row
= 0; row
< matrix_rows
; ++row
)
8293 for (col
= 0; col
< matrix_cols
; ++col
)
8295 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
8296 col
* matrix_rows
+ row
);
8297 gfc_constructor_insert_expr (&result
->value
.constructor
,
8298 gfc_copy_expr (e
), &matrix
->where
,
8299 row
* matrix_cols
+ col
);
8307 gfc_simplify_trim (gfc_expr
*e
)
8310 int count
, i
, len
, lentrim
;
8312 if (e
->expr_type
!= EXPR_CONSTANT
)
8315 len
= e
->value
.character
.length
;
8316 for (count
= 0, i
= 1; i
<= len
; ++i
)
8318 if (e
->value
.character
.string
[len
- i
] == ' ')
8324 lentrim
= len
- count
;
8326 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
8327 for (i
= 0; i
< lentrim
; i
++)
8328 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
8335 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
8340 gfc_constructor
*sub_cons
;
8344 if (!is_constant_array_expr (sub
))
8347 /* Follow any component references. */
8348 as
= coarray
->symtree
->n
.sym
->as
;
8349 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
8350 if (ref
->type
== REF_COMPONENT
)
8353 if (!as
|| as
->type
== AS_DEFERRED
)
8356 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
8357 the cosubscript addresses the first image. */
8359 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
8362 for (d
= 1; d
<= as
->corank
; d
++)
8367 gcc_assert (sub_cons
!= NULL
);
8369 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
8371 if (ca_bound
== NULL
)
8374 if (ca_bound
== &gfc_bad_expr
)
8377 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
8381 gfc_free_expr (ca_bound
);
8382 sub_cons
= gfc_constructor_next (sub_cons
);
8386 first_image
= false;
8390 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8391 "SUB has %ld and COARRAY lower bound is %ld)",
8393 mpz_get_si (sub_cons
->expr
->value
.integer
),
8394 mpz_get_si (ca_bound
->value
.integer
));
8395 gfc_free_expr (ca_bound
);
8396 return &gfc_bad_expr
;
8399 gfc_free_expr (ca_bound
);
8401 /* Check whether upperbound is valid for the multi-images case. */
8404 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
8406 if (ca_bound
== &gfc_bad_expr
)
8409 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
8410 && mpz_cmp (ca_bound
->value
.integer
,
8411 sub_cons
->expr
->value
.integer
) < 0)
8413 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8414 "SUB has %ld and COARRAY upper bound is %ld)",
8416 mpz_get_si (sub_cons
->expr
->value
.integer
),
8417 mpz_get_si (ca_bound
->value
.integer
));
8418 gfc_free_expr (ca_bound
);
8419 return &gfc_bad_expr
;
8423 gfc_free_expr (ca_bound
);
8426 sub_cons
= gfc_constructor_next (sub_cons
);
8429 gcc_assert (sub_cons
== NULL
);
8431 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
8434 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8435 &gfc_current_locus
);
8437 mpz_set_si (result
->value
.integer
, 1);
8439 mpz_set_si (result
->value
.integer
, 0);
8445 gfc_simplify_image_status (gfc_expr
*image
, gfc_expr
*team ATTRIBUTE_UNUSED
)
8447 if (flag_coarray
== GFC_FCOARRAY_NONE
)
8449 gfc_current_locus
= *gfc_current_intrinsic_where
;
8450 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
8451 return &gfc_bad_expr
;
8454 /* Simplification is possible for fcoarray = single only. For all other modes
8455 the result depends on runtime conditions. */
8456 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8459 if (gfc_is_constant_expr (image
))
8462 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8464 if (mpz_get_si (image
->value
.integer
) == 1)
8465 mpz_set_si (result
->value
.integer
, 0);
8467 mpz_set_si (result
->value
.integer
, GFC_STAT_STOPPED_IMAGE
);
8476 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
8477 gfc_expr
*distance ATTRIBUTE_UNUSED
)
8479 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8482 /* If no coarray argument has been passed or when the first argument
8483 is actually a distance argument. */
8484 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
8487 /* FIXME: gfc_current_locus is wrong. */
8488 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8489 &gfc_current_locus
);
8490 mpz_set_si (result
->value
.integer
, 1);
8494 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
8495 return simplify_cobound (coarray
, dim
, NULL
, 0);
8500 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8502 return simplify_bound (array
, dim
, kind
, 1);
8506 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8508 return simplify_cobound (array
, dim
, kind
, 1);
8513 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
8515 gfc_expr
*result
, *e
;
8516 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
8518 if (!is_constant_array_expr (vector
)
8519 || !is_constant_array_expr (mask
)
8520 || (!gfc_is_constant_expr (field
)
8521 && !is_constant_array_expr (field
)))
8524 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
8526 if (vector
->ts
.type
== BT_DERIVED
)
8527 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
8528 result
->rank
= mask
->rank
;
8529 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
8531 if (vector
->ts
.type
== BT_CHARACTER
)
8532 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
8534 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
8535 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
8537 = field
->expr_type
== EXPR_ARRAY
8538 ? gfc_constructor_first (field
->value
.constructor
)
8543 if (mask_ctor
->expr
->value
.logical
)
8547 e
= gfc_copy_expr (vector_ctor
->expr
);
8548 vector_ctor
= gfc_constructor_next (vector_ctor
);
8552 gfc_free_expr (result
);
8556 else if (field
->expr_type
== EXPR_ARRAY
)
8559 e
= gfc_copy_expr (field_ctor
->expr
);
8562 /* Not enough elements in array FIELD. */
8563 gfc_free_expr (result
);
8564 return &gfc_bad_expr
;
8568 e
= gfc_copy_expr (field
);
8570 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
8572 mask_ctor
= gfc_constructor_next (mask_ctor
);
8573 field_ctor
= gfc_constructor_next (field_ctor
);
8581 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
8585 size_t index
, len
, lenset
;
8587 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
8590 return &gfc_bad_expr
;
8592 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
8593 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
8596 if (b
!= NULL
&& b
->value
.logical
!= 0)
8601 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
8603 len
= s
->value
.character
.length
;
8604 lenset
= set
->value
.character
.length
;
8608 mpz_set_ui (result
->value
.integer
, 0);
8616 mpz_set_ui (result
->value
.integer
, 1);
8620 index
= wide_strspn (s
->value
.character
.string
,
8621 set
->value
.character
.string
) + 1;
8630 mpz_set_ui (result
->value
.integer
, len
);
8633 for (index
= len
; index
> 0; index
--)
8635 for (i
= 0; i
< lenset
; i
++)
8637 if (s
->value
.character
.string
[index
- 1]
8638 == set
->value
.character
.string
[i
])
8646 mpz_set_ui (result
->value
.integer
, index
);
8652 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
8657 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
8660 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
8665 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
8666 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
8667 return range_check (result
, "XOR");
8670 return gfc_get_logical_expr (kind
, &x
->where
,
8671 (x
->value
.logical
&& !y
->value
.logical
)
8672 || (!x
->value
.logical
&& y
->value
.logical
));
8680 /****************** Constant simplification *****************/
8682 /* Master function to convert one constant to another. While this is
8683 used as a simplification function, it requires the destination type
8684 and kind information which is supplied by a special case in
8688 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
8690 gfc_expr
*result
, *(*f
) (gfc_expr
*, int);
8691 gfc_constructor
*c
, *t
;
8705 f
= gfc_int2complex
;
8725 f
= gfc_real2complex
;
8736 f
= gfc_complex2int
;
8739 f
= gfc_complex2real
;
8742 f
= gfc_complex2complex
;
8768 f
= gfc_hollerith2int
;
8772 f
= gfc_hollerith2real
;
8776 f
= gfc_hollerith2complex
;
8780 f
= gfc_hollerith2character
;
8784 f
= gfc_hollerith2logical
;
8796 f
= gfc_character2int
;
8800 f
= gfc_character2real
;
8804 f
= gfc_character2complex
;
8808 f
= gfc_character2character
;
8812 f
= gfc_character2logical
;
8822 return &gfc_bad_expr
;
8827 switch (e
->expr_type
)
8830 result
= f (e
, kind
);
8832 return &gfc_bad_expr
;
8836 if (!gfc_is_constant_expr (e
))
8839 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8840 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8841 result
->rank
= e
->rank
;
8843 for (c
= gfc_constructor_first (e
->value
.constructor
);
8844 c
; c
= gfc_constructor_next (c
))
8847 if (c
->iterator
== NULL
)
8849 if (c
->expr
->expr_type
== EXPR_ARRAY
)
8850 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8851 else if (c
->expr
->expr_type
== EXPR_OP
)
8853 if (!gfc_simplify_expr (c
->expr
, 1))
8854 return &gfc_bad_expr
;
8855 tmp
= f (c
->expr
, kind
);
8858 tmp
= f (c
->expr
, kind
);
8861 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8863 if (tmp
== NULL
|| tmp
== &gfc_bad_expr
)
8865 gfc_free_expr (result
);
8869 t
= gfc_constructor_append_expr (&result
->value
.constructor
,
8872 t
->iterator
= gfc_copy_iterator (c
->iterator
);
8885 /* Function for converting character constants. */
8887 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
8892 if (!gfc_is_constant_expr (e
))
8895 if (e
->expr_type
== EXPR_CONSTANT
)
8897 /* Simple case of a scalar. */
8898 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
8900 return &gfc_bad_expr
;
8902 result
->value
.character
.length
= e
->value
.character
.length
;
8903 result
->value
.character
.string
8904 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
8905 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
8906 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
8908 /* Check we only have values representable in the destination kind. */
8909 for (i
= 0; i
< result
->value
.character
.length
; i
++)
8910 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
8913 gfc_error ("Character %qs in string at %L cannot be converted "
8914 "into character kind %d",
8915 gfc_print_wide_char (result
->value
.character
.string
[i
]),
8917 gfc_free_expr (result
);
8918 return &gfc_bad_expr
;
8923 else if (e
->expr_type
== EXPR_ARRAY
)
8925 /* For an array constructor, we convert each constructor element. */
8928 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8929 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8930 result
->rank
= e
->rank
;
8931 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
8933 for (c
= gfc_constructor_first (e
->value
.constructor
);
8934 c
; c
= gfc_constructor_next (c
))
8936 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
8937 if (tmp
== &gfc_bad_expr
)
8939 gfc_free_expr (result
);
8940 return &gfc_bad_expr
;
8945 gfc_free_expr (result
);
8949 gfc_constructor_append_expr (&result
->value
.constructor
,
8961 gfc_simplify_compiler_options (void)
8966 str
= gfc_get_option_string ();
8967 result
= gfc_get_character_expr (gfc_default_character_kind
,
8968 &gfc_current_locus
, str
, strlen (str
));
8975 gfc_simplify_compiler_version (void)
8980 len
= strlen ("GCC version ") + strlen (version_string
);
8981 buffer
= XALLOCAVEC (char, len
+ 1);
8982 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
8983 return gfc_get_character_expr (gfc_default_character_kind
,
8984 &gfc_current_locus
, buffer
, len
);
8987 /* Simplification routines for intrinsics of IEEE modules. */
8990 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
8992 gfc_actual_arglist
*arg
;
8993 gfc_expr
*p
= NULL
, *q
= NULL
, *rdx
= NULL
;
8995 arg
= expr
->value
.function
.actual
;
8999 q
= arg
->next
->expr
;
9000 if (arg
->next
->next
)
9001 rdx
= arg
->next
->next
->expr
;
9004 /* Currently, if IEEE is supported and this module is built, it means
9005 all our floating-point types conform to IEEE. Hence, we simply handle
9006 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
9007 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
9011 simplify_ieee_support (gfc_expr
*expr
)
9013 /* We consider that if the IEEE modules are loaded, we have full support
9014 for flags, halting and rounding, which are the three functions
9015 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
9016 expressions. One day, we will need libgfortran to detect support and
9017 communicate it back to us, allowing for partial support. */
9019 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
9024 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
9026 int n
= strlen(name
);
9028 if (!strncmp(sym
->name
, name
, n
))
9031 /* If a generic was used and renamed, we need more work to find out.
9032 Compare the specific name. */
9033 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
9040 gfc_simplify_ieee_functions (gfc_expr
*expr
)
9042 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
9044 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
9045 return simplify_ieee_selected_real_kind (expr
);
9046 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
9047 || matches_ieee_function_name(sym
, "ieee_support_halting")
9048 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
9049 return simplify_ieee_support (expr
);