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 /* Then, we need to know the extent of the given dimension. */
4119 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
4121 gfc_expr
*declared_bound
;
4123 bool constant_lbound
, constant_ubound
;
4128 gcc_assert (l
!= NULL
);
4130 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
4131 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
4133 empty_bound
= upper
? 0 : 1;
4134 declared_bound
= upper
? u
: l
;
4136 if ((!upper
&& !constant_lbound
)
4137 || (upper
&& !constant_ubound
))
4142 /* For {L,U}BOUND, the value depends on whether the array
4143 is empty. We can nevertheless simplify if the declared bound
4144 has the same value as that of an empty array, in which case
4145 the result isn't dependent on the array emptiness. */
4146 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
4147 mpz_set_si (result
->value
.integer
, empty_bound
);
4148 else if (!constant_lbound
|| !constant_ubound
)
4149 /* Array emptiness can't be determined, we can't simplify. */
4151 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
4152 mpz_set_si (result
->value
.integer
, empty_bound
);
4154 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4157 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4163 int d2
= 0, cnt
= 0;
4164 for (int idx
= 0; idx
< ref
->u
.ar
.dimen
; ++idx
)
4166 if (ref
->u
.ar
.dimen_type
[idx
] == DIMEN_ELEMENT
)
4168 else if (cnt
< d
- 1)
4173 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d2
+ d
- 1, &result
->value
.integer
, NULL
))
4177 mpz_set_si (result
->value
.integer
, (long int) 1);
4181 return range_check (result
, upper
? "UBOUND" : "LBOUND");
4184 gfc_free_expr (result
);
4190 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4194 ar_type type
= AR_UNKNOWN
;
4197 if (array
->ts
.type
== BT_CLASS
)
4200 if (array
->expr_type
!= EXPR_VARIABLE
)
4207 /* Do not attempt to resolve if error has already been issued. */
4208 if (array
->symtree
->n
.sym
->error
)
4211 /* Follow any component references. */
4212 as
= array
->symtree
->n
.sym
->as
;
4213 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4218 type
= ref
->u
.ar
.type
;
4219 switch (ref
->u
.ar
.type
)
4226 /* We're done because 'as' has already been set in the
4227 previous iteration. */
4241 as
= ref
->u
.c
.component
->as
;
4254 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
4255 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
4258 /* 'array' shall not be an unallocated allocatable variable or a pointer that
4259 is not associated. */
4260 if (array
->expr_type
== EXPR_VARIABLE
4261 && (gfc_expr_attr (array
).allocatable
|| gfc_expr_attr (array
).pointer
))
4265 || (as
->type
!= AS_DEFERRED
4266 && array
->expr_type
== EXPR_VARIABLE
4267 && !gfc_expr_attr (array
).allocatable
4268 && !gfc_expr_attr (array
).pointer
));
4272 /* Multi-dimensional bounds. */
4273 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4277 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4278 if (upper
&& type
== AR_FULL
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
4280 /* An error message will be emitted in
4281 check_assumed_size_reference (resolve.cc). */
4282 return &gfc_bad_expr
;
4285 /* Simplify the bounds for each dimension. */
4286 for (d
= 0; d
< array
->rank
; d
++)
4288 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
4290 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4294 for (j
= 0; j
< d
; j
++)
4295 gfc_free_expr (bounds
[j
]);
4298 return &gfc_bad_expr
;
4304 /* Allocate the result expression. */
4305 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4306 gfc_default_integer_kind
);
4308 return &gfc_bad_expr
;
4310 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
4312 /* The result is a rank 1 array; its size is the rank of the first
4313 argument to {L,U}BOUND. */
4315 e
->shape
= gfc_get_shape (1);
4316 mpz_init_set_ui (e
->shape
[0], array
->rank
);
4318 /* Create the constructor for this array. */
4319 for (d
= 0; d
< array
->rank
; d
++)
4320 gfc_constructor_append_expr (&e
->value
.constructor
,
4321 bounds
[d
], &e
->where
);
4327 /* A DIM argument is specified. */
4328 if (dim
->expr_type
!= EXPR_CONSTANT
)
4331 d
= mpz_get_si (dim
->value
.integer
);
4333 if ((d
< 1 || d
> array
->rank
)
4334 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
4336 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4337 return &gfc_bad_expr
;
4340 if (as
&& as
->type
== AS_ASSUMED_RANK
)
4343 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
4349 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4355 if (array
->expr_type
!= EXPR_VARIABLE
)
4358 /* Follow any component references. */
4359 as
= (array
->ts
.type
== BT_CLASS
&& CLASS_DATA (array
))
4360 ? CLASS_DATA (array
)->as
4361 : array
->symtree
->n
.sym
->as
;
4362 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4367 switch (ref
->u
.ar
.type
)
4370 if (ref
->u
.ar
.as
->corank
> 0)
4372 gcc_assert (as
== ref
->u
.ar
.as
);
4379 /* We're done because 'as' has already been set in the
4380 previous iteration. */
4394 as
= ref
->u
.c
.component
->as
;
4408 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
4413 /* Multi-dimensional cobounds. */
4414 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4418 /* Simplify the cobounds for each dimension. */
4419 for (d
= 0; d
< as
->corank
; d
++)
4421 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
4422 upper
, as
, ref
, true);
4423 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4427 for (j
= 0; j
< d
; j
++)
4428 gfc_free_expr (bounds
[j
]);
4433 /* Allocate the result expression. */
4434 e
= gfc_get_expr ();
4435 e
->where
= array
->where
;
4436 e
->expr_type
= EXPR_ARRAY
;
4437 e
->ts
.type
= BT_INTEGER
;
4438 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
4439 gfc_default_integer_kind
);
4443 return &gfc_bad_expr
;
4447 /* The result is a rank 1 array; its size is the rank of the first
4448 argument to {L,U}COBOUND. */
4450 e
->shape
= gfc_get_shape (1);
4451 mpz_init_set_ui (e
->shape
[0], as
->corank
);
4453 /* Create the constructor for this array. */
4454 for (d
= 0; d
< as
->corank
; d
++)
4455 gfc_constructor_append_expr (&e
->value
.constructor
,
4456 bounds
[d
], &e
->where
);
4461 /* A DIM argument is specified. */
4462 if (dim
->expr_type
!= EXPR_CONSTANT
)
4465 d
= mpz_get_si (dim
->value
.integer
);
4467 if (d
< 1 || d
> as
->corank
)
4469 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4470 return &gfc_bad_expr
;
4473 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
4479 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4481 return simplify_bound (array
, dim
, kind
, 0);
4486 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4488 return simplify_cobound (array
, dim
, kind
, 0);
4492 gfc_simplify_leadz (gfc_expr
*e
)
4494 unsigned long lz
, bs
;
4497 if (e
->expr_type
!= EXPR_CONSTANT
)
4500 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4501 bs
= gfc_integer_kinds
[i
].bit_size
;
4502 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
4504 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
4507 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
4509 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
4513 /* Check for constant length of a substring. */
4516 substring_has_constant_len (gfc_expr
*e
)
4519 HOST_WIDE_INT istart
, iend
, length
;
4520 bool equal_length
= false;
4522 if (e
->ts
.type
!= BT_CHARACTER
)
4525 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4526 if (ref
->type
!= REF_COMPONENT
&& ref
->type
!= REF_ARRAY
)
4530 || ref
->type
!= REF_SUBSTRING
4532 || ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
4534 || ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
4537 /* Basic checks on substring starting and ending indices. */
4538 if (!gfc_resolve_substring (ref
, &equal_length
))
4541 istart
= gfc_mpz_get_hwi (ref
->u
.ss
.start
->value
.integer
);
4542 iend
= gfc_mpz_get_hwi (ref
->u
.ss
.end
->value
.integer
);
4545 length
= iend
- istart
+ 1;
4549 /* Fix substring length. */
4550 e
->value
.character
.length
= length
;
4557 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
4560 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
4563 return &gfc_bad_expr
;
4565 if (e
->expr_type
== EXPR_CONSTANT
4566 || substring_has_constant_len (e
))
4568 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4569 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
4570 return range_check (result
, "LEN");
4572 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
4573 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
4574 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
4576 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4577 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
4578 return range_check (result
, "LEN");
4580 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
4581 && e
->symtree
->n
.sym
)
4583 if (e
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
4584 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
4585 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
4586 && e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
4587 && UNLIMITED_POLY (e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
))
4588 /* The expression in assoc->target points to a ref to the _data
4589 component of the unlimited polymorphic entity. To get the _len
4590 component the last _data ref needs to be stripped and a ref to the
4591 _len component added. */
4592 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
, k
);
4593 else if (e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
4594 && e
->ref
&& e
->ref
->type
== REF_COMPONENT
4595 && e
->ref
->u
.c
.component
->attr
.pdt_string
4596 && e
->ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4597 && e
->ref
->u
.c
.component
->ts
.u
.cl
->length
)
4599 if (gfc_init_expr_flag
)
4602 tmp
= gfc_pdt_find_component_copy_initializer (e
->symtree
->n
.sym
,
4612 gfc_expr
*len_expr
= gfc_copy_expr (e
);
4613 gfc_free_ref_list (len_expr
->ref
);
4614 len_expr
->ref
= NULL
;
4615 gfc_find_component (len_expr
->symtree
->n
.sym
->ts
.u
.derived
, e
->ref
4616 ->u
.c
.component
->ts
.u
.cl
->length
->symtree
4618 false, true, &len_expr
->ref
);
4619 len_expr
->ts
= len_expr
->ref
->u
.c
.component
->ts
;
4629 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
4632 size_t count
, len
, i
;
4633 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
4636 return &gfc_bad_expr
;
4638 /* If the expression is either an array element or section, an array
4639 parameter must be built so that the reference can be applied. Constant
4640 references should have already been simplified away. All other cases
4641 can proceed to translation, where kind conversion will occur silently. */
4642 if (e
->expr_type
== EXPR_VARIABLE
4643 && e
->ts
.type
== BT_CHARACTER
4644 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
4645 && e
->ref
&& e
->ref
->type
== REF_ARRAY
4646 && e
->ref
->u
.ar
.type
!= AR_FULL
4647 && e
->symtree
->n
.sym
->value
)
4649 char name
[2*GFC_MAX_SYMBOL_LEN
+ 12];
4650 gfc_namespace
*ns
= e
->symtree
->n
.sym
->ns
;
4657 sprintf (name
, "_len_trim_%s_%s", e
->symtree
->n
.sym
->name
,
4658 ns
->proc_name
->name
);
4659 st
= gfc_find_symtree (ns
->sym_root
, name
);
4663 /* Recursively call this fcn to simplify the constructor elements. */
4664 expr
= gfc_copy_expr (e
->symtree
->n
.sym
->value
);
4665 expr
->ts
.type
= BT_INTEGER
;
4667 expr
->ts
.u
.cl
= NULL
;
4668 c
= gfc_constructor_first (expr
->value
.constructor
);
4669 for (; c
; c
= gfc_constructor_next (c
))
4674 if (c
->expr
&& c
->expr
->ts
.type
== BT_CHARACTER
)
4676 p
= gfc_simplify_len_trim (c
->expr
, kind
);
4679 gfc_replace_expr (c
->expr
, p
);
4686 /* Build a new parameter to take the result. */
4687 st
= gfc_new_symtree (&ns
->sym_root
, name
);
4688 st
->n
.sym
= gfc_new_symbol (st
->name
, ns
);
4689 st
->n
.sym
->value
= expr
;
4690 st
->n
.sym
->ts
= expr
->ts
;
4691 st
->n
.sym
->attr
.dimension
= 1;
4692 st
->n
.sym
->attr
.save
= SAVE_IMPLICIT
;
4693 st
->n
.sym
->attr
.flavor
= FL_PARAMETER
;
4694 st
->n
.sym
->as
= gfc_copy_array_spec (e
->symtree
->n
.sym
->as
);
4695 gfc_set_sym_referenced (st
->n
.sym
);
4697 gfc_commit_symbol (st
->n
.sym
);
4700 /* Build a return expression. */
4701 expr
= gfc_copy_expr (e
);
4702 expr
->ts
= st
->n
.sym
->ts
;
4704 gfc_expression_rank (expr
);
4709 gfc_free_expr (expr
);
4713 if (e
->expr_type
!= EXPR_CONSTANT
)
4716 len
= e
->value
.character
.length
;
4717 for (count
= 0, i
= 1; i
<= len
; i
++)
4718 if (e
->value
.character
.string
[len
- i
] == ' ')
4723 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
4724 return range_check (result
, "LEN_TRIM");
4728 gfc_simplify_lgamma (gfc_expr
*x
)
4733 if (x
->expr_type
!= EXPR_CONSTANT
)
4736 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4737 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
4739 return range_check (result
, "LGAMMA");
4744 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
4746 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4749 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4750 gfc_compare_string (a
, b
) >= 0);
4755 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
4757 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4760 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4761 gfc_compare_string (a
, b
) > 0);
4766 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
4768 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4771 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4772 gfc_compare_string (a
, b
) <= 0);
4777 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
4779 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4782 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4783 gfc_compare_string (a
, b
) < 0);
4788 gfc_simplify_log (gfc_expr
*x
)
4792 if (x
->expr_type
!= EXPR_CONSTANT
)
4795 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4800 if (mpfr_sgn (x
->value
.real
) <= 0)
4802 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4803 "to zero", &x
->where
);
4804 gfc_free_expr (result
);
4805 return &gfc_bad_expr
;
4808 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4812 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
4813 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
4815 gfc_error ("Complex argument of LOG at %L cannot be zero",
4817 gfc_free_expr (result
);
4818 return &gfc_bad_expr
;
4821 gfc_set_model_kind (x
->ts
.kind
);
4822 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
4826 gfc_internal_error ("gfc_simplify_log: bad type");
4829 return range_check (result
, "LOG");
4834 gfc_simplify_log10 (gfc_expr
*x
)
4838 if (x
->expr_type
!= EXPR_CONSTANT
)
4841 if (mpfr_sgn (x
->value
.real
) <= 0)
4843 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4844 "to zero", &x
->where
);
4845 return &gfc_bad_expr
;
4848 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4849 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4851 return range_check (result
, "LOG10");
4856 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
4860 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
4862 return &gfc_bad_expr
;
4864 if (e
->expr_type
!= EXPR_CONSTANT
)
4867 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
4872 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
4875 int row
, result_rows
, col
, result_columns
;
4876 int stride_a
, offset_a
, stride_b
, offset_b
;
4878 if (!is_constant_array_expr (matrix_a
)
4879 || !is_constant_array_expr (matrix_b
))
4882 /* MATMUL should do mixed-mode arithmetic. Set the result type. */
4883 if (matrix_a
->ts
.type
!= matrix_b
->ts
.type
)
4886 e
.expr_type
= EXPR_OP
;
4887 gfc_clear_ts (&e
.ts
);
4888 e
.value
.op
.op
= INTRINSIC_NONE
;
4889 e
.value
.op
.op1
= matrix_a
;
4890 e
.value
.op
.op2
= matrix_b
;
4891 gfc_type_convert_binary (&e
, 1);
4892 result
= gfc_get_array_expr (e
.ts
.type
, e
.ts
.kind
, &matrix_a
->where
);
4896 result
= gfc_get_array_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
4900 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
4903 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4905 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4908 result
->shape
= gfc_get_shape (result
->rank
);
4909 mpz_init_set_si (result
->shape
[0], result_columns
);
4911 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
4913 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4915 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4919 result
->shape
= gfc_get_shape (result
->rank
);
4920 mpz_init_set_si (result
->shape
[0], result_rows
);
4922 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
4924 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4925 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4926 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4927 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4930 result
->shape
= gfc_get_shape (result
->rank
);
4931 mpz_init_set_si (result
->shape
[0], result_rows
);
4932 mpz_init_set_si (result
->shape
[1], result_columns
);
4938 for (col
= 0; col
< result_columns
; ++col
)
4942 for (row
= 0; row
< result_rows
; ++row
)
4944 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
4945 matrix_b
, 1, offset_b
, false);
4946 gfc_constructor_append_expr (&result
->value
.constructor
,
4952 offset_b
+= stride_b
;
4960 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
4965 if (i
->expr_type
!= EXPR_CONSTANT
)
4968 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
4970 return &gfc_bad_expr
;
4971 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4973 bool fail
= gfc_extract_int (i
, &arg
);
4976 if (!gfc_check_mask (i
, kind_arg
))
4977 return &gfc_bad_expr
;
4979 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4981 /* MASKR(n) = 2^n - 1 */
4982 mpz_set_ui (result
->value
.integer
, 1);
4983 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4984 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4986 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4993 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4999 if (i
->expr_type
!= EXPR_CONSTANT
)
5002 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
5004 return &gfc_bad_expr
;
5005 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
5007 bool fail
= gfc_extract_int (i
, &arg
);
5010 if (!gfc_check_mask (i
, kind_arg
))
5011 return &gfc_bad_expr
;
5013 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
5015 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
5016 mpz_init_set_ui (z
, 1);
5017 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
5018 mpz_set_ui (result
->value
.integer
, 1);
5019 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
5020 gfc_integer_kinds
[k
].bit_size
- arg
);
5021 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
5024 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
5031 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
5034 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
5036 if (mask
->expr_type
== EXPR_CONSTANT
)
5038 /* The standard requires evaluation of all function arguments.
5039 Simplify only when the other dropped argument (FSOURCE or TSOURCE)
5040 is a constant expression. */
5041 if (mask
->value
.logical
)
5043 if (!gfc_is_constant_expr (fsource
))
5045 result
= gfc_copy_expr (tsource
);
5049 if (!gfc_is_constant_expr (tsource
))
5051 result
= gfc_copy_expr (fsource
);
5054 /* Parenthesis is needed to get lower bounds of 1. */
5055 result
= gfc_get_parentheses (result
);
5056 gfc_simplify_expr (result
, 1);
5060 if (!mask
->rank
|| !is_constant_array_expr (mask
)
5061 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
5064 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
5066 if (tsource
->ts
.type
== BT_DERIVED
)
5067 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
5068 else if (tsource
->ts
.type
== BT_CHARACTER
)
5069 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
5071 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
5072 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
5073 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5077 if (mask_ctor
->expr
->value
.logical
)
5078 gfc_constructor_append_expr (&result
->value
.constructor
,
5079 gfc_copy_expr (tsource_ctor
->expr
),
5082 gfc_constructor_append_expr (&result
->value
.constructor
,
5083 gfc_copy_expr (fsource_ctor
->expr
),
5085 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
5086 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
5087 mask_ctor
= gfc_constructor_next (mask_ctor
);
5090 result
->shape
= gfc_get_shape (1);
5091 gfc_array_size (result
, &result
->shape
[0]);
5098 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
5100 mpz_t arg1
, arg2
, mask
;
5103 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
5104 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
5107 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
5109 /* Convert all argument to unsigned. */
5110 mpz_init_set (arg1
, i
->value
.integer
);
5111 mpz_init_set (arg2
, j
->value
.integer
);
5112 mpz_init_set (mask
, mask_expr
->value
.integer
);
5114 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
5115 mpz_and (arg1
, arg1
, mask
);
5116 mpz_com (mask
, mask
);
5117 mpz_and (arg2
, arg2
, mask
);
5118 mpz_ior (result
->value
.integer
, arg1
, arg2
);
5128 /* Selects between current value and extremum for simplify_min_max
5129 and simplify_minval_maxval. */
5131 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
, bool back_val
)
5135 switch (arg
->ts
.type
)
5138 if (extremum
->ts
.kind
< arg
->ts
.kind
)
5139 extremum
->ts
.kind
= arg
->ts
.kind
;
5140 ret
= mpz_cmp (arg
->value
.integer
,
5141 extremum
->value
.integer
) * sign
;
5143 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
5147 if (extremum
->ts
.kind
< arg
->ts
.kind
)
5148 extremum
->ts
.kind
= arg
->ts
.kind
;
5149 if (mpfr_nan_p (extremum
->value
.real
))
5152 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
5154 else if (mpfr_nan_p (arg
->value
.real
))
5158 ret
= mpfr_cmp (arg
->value
.real
, extremum
->value
.real
) * sign
;
5160 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
5165 #define LENGTH(x) ((x)->value.character.length)
5166 #define STRING(x) ((x)->value.character.string)
5167 if (LENGTH (extremum
) < LENGTH(arg
))
5169 gfc_char_t
*tmp
= STRING(extremum
);
5171 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
5172 memcpy (STRING(extremum
), tmp
,
5173 LENGTH(extremum
) * sizeof (gfc_char_t
));
5174 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
5175 LENGTH(arg
) - LENGTH(extremum
));
5176 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
5177 LENGTH(extremum
) = LENGTH(arg
);
5180 ret
= gfc_compare_string (arg
, extremum
) * sign
;
5183 free (STRING(extremum
));
5184 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
5185 memcpy (STRING(extremum
), STRING(arg
),
5186 LENGTH(arg
) * sizeof (gfc_char_t
));
5187 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
5188 LENGTH(extremum
) - LENGTH(arg
));
5189 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
5196 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5198 if (back_val
&& ret
== 0)
5205 /* This function is special since MAX() can take any number of
5206 arguments. The simplified expression is a rewritten version of the
5207 argument list containing at most one constant element. Other
5208 constant elements are deleted. Because the argument list has
5209 already been checked, this function always succeeds. sign is 1 for
5210 MAX(), -1 for MIN(). */
5213 simplify_min_max (gfc_expr
*expr
, int sign
)
5216 gfc_actual_arglist
*arg
, *last
, *extremum
;
5217 gfc_expr
*tmp
, *ret
;
5223 arg
= expr
->value
.function
.actual
;
5225 for (; arg
; last
= arg
, arg
= arg
->next
)
5227 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
5230 if (extremum
== NULL
)
5236 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
5238 /* Delete the extra constant argument. */
5239 last
->next
= arg
->next
;
5242 gfc_free_actual_arglist (arg
);
5246 /* If there is one value left, replace the function call with the
5248 if (expr
->value
.function
.actual
->next
!= NULL
)
5251 /* Handle special cases of specific functions (min|max)1 and
5254 tmp
= expr
->value
.function
.actual
->expr
;
5255 fname
= expr
->value
.function
.isym
->name
;
5257 if ((tmp
->ts
.type
!= BT_INTEGER
|| tmp
->ts
.kind
!= gfc_integer_4_kind
)
5258 && (strcmp (fname
, "min1") == 0 || strcmp (fname
, "max1") == 0))
5260 /* Explicit conversion, turn off -Wconversion and -Wconversion-extra
5262 tmp1
= warn_conversion
;
5263 tmp2
= warn_conversion_extra
;
5264 warn_conversion
= warn_conversion_extra
= 0;
5266 ret
= gfc_convert_constant (tmp
, BT_INTEGER
, gfc_integer_4_kind
);
5268 warn_conversion
= tmp1
;
5269 warn_conversion_extra
= tmp2
;
5271 else if ((tmp
->ts
.type
!= BT_REAL
|| tmp
->ts
.kind
!= gfc_real_4_kind
)
5272 && (strcmp (fname
, "amin0") == 0 || strcmp (fname
, "amax0") == 0))
5274 ret
= gfc_convert_constant (tmp
, BT_REAL
, gfc_real_4_kind
);
5277 ret
= gfc_copy_expr (tmp
);
5285 gfc_simplify_min (gfc_expr
*e
)
5287 return simplify_min_max (e
, -1);
5292 gfc_simplify_max (gfc_expr
*e
)
5294 return simplify_min_max (e
, 1);
5297 /* Helper function for gfc_simplify_minval. */
5300 gfc_min (gfc_expr
*op1
, gfc_expr
*op2
)
5302 min_max_choose (op1
, op2
, -1);
5303 gfc_free_expr (op1
);
5307 /* Simplify minval for constant arrays. */
5310 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5312 return simplify_transformation (array
, dim
, mask
, INT_MAX
, gfc_min
);
5315 /* Helper function for gfc_simplify_maxval. */
5318 gfc_max (gfc_expr
*op1
, gfc_expr
*op2
)
5320 min_max_choose (op1
, op2
, 1);
5321 gfc_free_expr (op1
);
5326 /* Simplify maxval for constant arrays. */
5329 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5331 return simplify_transformation (array
, dim
, mask
, INT_MIN
, gfc_max
);
5335 /* Transform minloc or maxloc of an array, according to MASK,
5336 to the scalar result. This code is mostly identical to
5337 simplify_transformation_to_scalar. */
5340 simplify_minmaxloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
5341 gfc_expr
*extremum
, int sign
, bool back_val
)
5344 gfc_constructor
*array_ctor
, *mask_ctor
;
5347 mpz_set_si (result
->value
.integer
, 0);
5350 /* Shortcut for constant .FALSE. MASK. */
5352 && mask
->expr_type
== EXPR_CONSTANT
5353 && !mask
->value
.logical
)
5356 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5357 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5358 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5362 mpz_init_set_si (count
, 0);
5365 mpz_add_ui (count
, count
, 1);
5366 a
= array_ctor
->expr
;
5367 array_ctor
= gfc_constructor_next (array_ctor
);
5368 /* A constant MASK equals .TRUE. here and can be ignored. */
5371 m
= mask_ctor
->expr
;
5372 mask_ctor
= gfc_constructor_next (mask_ctor
);
5373 if (!m
->value
.logical
)
5376 if (min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5377 mpz_set (result
->value
.integer
, count
);
5380 gfc_free_expr (extremum
);
5384 /* Simplify minloc / maxloc in the absence of a dim argument. */
5387 simplify_minmaxloc_nodim (gfc_expr
*result
, gfc_expr
*extremum
,
5388 gfc_expr
*array
, gfc_expr
*mask
, int sign
,
5391 ssize_t res
[GFC_MAX_DIMENSIONS
];
5393 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5394 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5395 sstride
[GFC_MAX_DIMENSIONS
];
5400 for (i
= 0; i
<array
->rank
; i
++)
5403 /* Shortcut for constant .FALSE. MASK. */
5405 && mask
->expr_type
== EXPR_CONSTANT
5406 && !mask
->value
.logical
)
5409 if (array
->shape
== NULL
)
5412 for (i
= 0; i
< array
->rank
; i
++)
5415 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5416 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5421 continue_loop
= true;
5422 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5423 if (mask
&& mask
->rank
> 0)
5424 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5428 /* Loop over the array elements (and mask), keeping track of
5429 the indices to return. */
5430 while (continue_loop
)
5434 a
= array_ctor
->expr
;
5437 m
= mask_ctor
->expr
;
5438 ma
= m
->value
.logical
;
5439 mask_ctor
= gfc_constructor_next (mask_ctor
);
5444 if (ma
&& min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5446 for (i
= 0; i
<array
->rank
; i
++)
5449 array_ctor
= gfc_constructor_next (array_ctor
);
5451 } while (count
[0] != extent
[0]);
5455 /* When we get to the end of a dimension, reset it and increment
5456 the next dimension. */
5459 if (n
>= array
->rank
)
5461 continue_loop
= false;
5466 } while (count
[n
] == extent
[n
]);
5470 gfc_free_expr (extremum
);
5471 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5472 for (i
= 0; i
<array
->rank
; i
++)
5475 r_expr
= result_ctor
->expr
;
5476 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5477 result_ctor
= gfc_constructor_next (result_ctor
);
5482 /* Helper function for gfc_simplify_minmaxloc - build an array
5483 expression with n elements. */
5486 new_array (bt type
, int kind
, int n
, locus
*where
)
5491 result
= gfc_get_array_expr (type
, kind
, where
);
5493 result
->shape
= gfc_get_shape(1);
5494 mpz_init_set_si (result
->shape
[0], n
);
5495 for (i
= 0; i
< n
; i
++)
5497 gfc_constructor_append_expr (&result
->value
.constructor
,
5498 gfc_get_constant_expr (type
, kind
, where
),
5505 /* Simplify minloc and maxloc. This code is mostly identical to
5506 simplify_transformation_to_array. */
5509 simplify_minmaxloc_to_array (gfc_expr
*result
, gfc_expr
*array
,
5510 gfc_expr
*dim
, gfc_expr
*mask
,
5511 gfc_expr
*extremum
, int sign
, bool back_val
)
5514 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5515 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5516 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5518 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5519 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5520 tmpstride
[GFC_MAX_DIMENSIONS
];
5522 /* Shortcut for constant .FALSE. MASK. */
5524 && mask
->expr_type
== EXPR_CONSTANT
5525 && !mask
->value
.logical
)
5528 /* Build an indexed table for array element expressions to minimize
5529 linked-list traversal. Masked elements are set to NULL. */
5530 gfc_array_size (array
, &size
);
5531 arraysize
= mpz_get_ui (size
);
5534 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5536 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5538 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5539 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5541 for (i
= 0; i
< arraysize
; ++i
)
5543 arrayvec
[i
] = array_ctor
->expr
;
5544 array_ctor
= gfc_constructor_next (array_ctor
);
5548 if (!mask_ctor
->expr
->value
.logical
)
5551 mask_ctor
= gfc_constructor_next (mask_ctor
);
5555 /* Same for the result expression. */
5556 gfc_array_size (result
, &size
);
5557 resultsize
= mpz_get_ui (size
);
5560 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5561 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5562 for (i
= 0; i
< resultsize
; ++i
)
5564 resultvec
[i
] = result_ctor
->expr
;
5565 result_ctor
= gfc_constructor_next (result_ctor
);
5568 gfc_extract_int (dim
, &dim_index
);
5569 dim_index
-= 1; /* zero-base index */
5573 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5576 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5579 dim_extent
= mpz_get_si (array
->shape
[i
]);
5580 dim_stride
= tmpstride
[i
];
5584 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5585 sstride
[n
] = tmpstride
[i
];
5586 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5590 done
= resultsize
<= 0;
5596 ex
= gfc_copy_expr (extremum
);
5597 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5599 if (*src
&& min_max_choose (*src
, ex
, sign
, back_val
) > 0)
5600 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5609 while (!done
&& count
[n
] == extent
[n
])
5612 base
-= sstride
[n
] * extent
[n
];
5613 dest
-= dstride
[n
] * extent
[n
];
5616 if (n
< result
->rank
)
5618 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5619 times, we'd warn for the last iteration, because the
5620 array index will have already been incremented to the
5621 array sizes, and we can't tell that this must make
5622 the test against result->rank false, because ranks
5623 must not exceed GFC_MAX_DIMENSIONS. */
5624 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5635 /* Place updated expression in result constructor. */
5636 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5637 for (i
= 0; i
< resultsize
; ++i
)
5639 result_ctor
->expr
= resultvec
[i
];
5640 result_ctor
= gfc_constructor_next (result_ctor
);
5649 /* Simplify minloc and maxloc for constant arrays. */
5652 gfc_simplify_minmaxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
5653 gfc_expr
*kind
, gfc_expr
*back
, int sign
)
5659 bool back_val
= false;
5661 if (!is_constant_array_expr (array
)
5662 || !gfc_is_constant_expr (dim
))
5666 && !is_constant_array_expr (mask
)
5667 && mask
->expr_type
!= EXPR_CONSTANT
)
5672 if (gfc_extract_int (kind
, &ikind
, -1))
5676 ikind
= gfc_default_integer_kind
;
5680 if (back
->expr_type
!= EXPR_CONSTANT
)
5683 back_val
= back
->value
.logical
;
5693 extremum
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
5694 init_result_expr (extremum
, init_val
, array
);
5698 result
= transformational_result (array
, dim
, BT_INTEGER
,
5699 ikind
, &array
->where
);
5700 init_result_expr (result
, 0, array
);
5702 if (array
->rank
== 1)
5703 return simplify_minmaxloc_to_scalar (result
, array
, mask
, extremum
,
5706 return simplify_minmaxloc_to_array (result
, array
, dim
, mask
, extremum
,
5711 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5712 return simplify_minmaxloc_nodim (result
, extremum
, array
, mask
,
5718 gfc_simplify_minloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5721 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, -1);
5725 gfc_simplify_maxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5728 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, 1);
5731 /* Simplify findloc to scalar. Similar to
5732 simplify_minmaxloc_to_scalar. */
5735 simplify_findloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5736 gfc_expr
*mask
, int back_val
)
5739 gfc_constructor
*array_ctor
, *mask_ctor
;
5742 mpz_set_si (result
->value
.integer
, 0);
5744 /* Shortcut for constant .FALSE. MASK. */
5746 && mask
->expr_type
== EXPR_CONSTANT
5747 && !mask
->value
.logical
)
5750 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5751 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5752 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5756 mpz_init_set_si (count
, 0);
5759 mpz_add_ui (count
, count
, 1);
5760 a
= array_ctor
->expr
;
5761 array_ctor
= gfc_constructor_next (array_ctor
);
5762 /* A constant MASK equals .TRUE. here and can be ignored. */
5765 m
= mask_ctor
->expr
;
5766 mask_ctor
= gfc_constructor_next (mask_ctor
);
5767 if (!m
->value
.logical
)
5770 if (gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5772 /* We have a match. If BACK is true, continue so we find
5774 mpz_set (result
->value
.integer
, count
);
5783 /* Simplify findloc in the absence of a dim argument. Similar to
5784 simplify_minmaxloc_nodim. */
5787 simplify_findloc_nodim (gfc_expr
*result
, gfc_expr
*value
, gfc_expr
*array
,
5788 gfc_expr
*mask
, bool back_val
)
5790 ssize_t res
[GFC_MAX_DIMENSIONS
];
5792 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5793 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5794 sstride
[GFC_MAX_DIMENSIONS
];
5799 for (i
= 0; i
< array
->rank
; i
++)
5802 /* Shortcut for constant .FALSE. MASK. */
5804 && mask
->expr_type
== EXPR_CONSTANT
5805 && !mask
->value
.logical
)
5808 for (i
= 0; i
< array
->rank
; i
++)
5811 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5812 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5817 continue_loop
= true;
5818 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5819 if (mask
&& mask
->rank
> 0)
5820 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5824 /* Loop over the array elements (and mask), keeping track of
5825 the indices to return. */
5826 while (continue_loop
)
5830 a
= array_ctor
->expr
;
5833 m
= mask_ctor
->expr
;
5834 ma
= m
->value
.logical
;
5835 mask_ctor
= gfc_constructor_next (mask_ctor
);
5840 if (ma
&& gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5842 for (i
= 0; i
< array
->rank
; i
++)
5847 array_ctor
= gfc_constructor_next (array_ctor
);
5849 } while (count
[0] != extent
[0]);
5853 /* When we get to the end of a dimension, reset it and increment
5854 the next dimension. */
5857 if (n
>= array
->rank
)
5859 continue_loop
= false;
5864 } while (count
[n
] == extent
[n
]);
5868 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5869 for (i
= 0; i
< array
->rank
; i
++)
5872 r_expr
= result_ctor
->expr
;
5873 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5874 result_ctor
= gfc_constructor_next (result_ctor
);
5880 /* Simplify findloc to an array. Similar to
5881 simplify_minmaxloc_to_array. */
5884 simplify_findloc_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5885 gfc_expr
*dim
, gfc_expr
*mask
, bool back_val
)
5888 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5889 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5890 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5892 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5893 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5894 tmpstride
[GFC_MAX_DIMENSIONS
];
5896 /* Shortcut for constant .FALSE. MASK. */
5898 && mask
->expr_type
== EXPR_CONSTANT
5899 && !mask
->value
.logical
)
5902 /* Build an indexed table for array element expressions to minimize
5903 linked-list traversal. Masked elements are set to NULL. */
5904 gfc_array_size (array
, &size
);
5905 arraysize
= mpz_get_ui (size
);
5908 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5910 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5912 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5913 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5915 for (i
= 0; i
< arraysize
; ++i
)
5917 arrayvec
[i
] = array_ctor
->expr
;
5918 array_ctor
= gfc_constructor_next (array_ctor
);
5922 if (!mask_ctor
->expr
->value
.logical
)
5925 mask_ctor
= gfc_constructor_next (mask_ctor
);
5929 /* Same for the result expression. */
5930 gfc_array_size (result
, &size
);
5931 resultsize
= mpz_get_ui (size
);
5934 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5935 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5936 for (i
= 0; i
< resultsize
; ++i
)
5938 resultvec
[i
] = result_ctor
->expr
;
5939 result_ctor
= gfc_constructor_next (result_ctor
);
5942 gfc_extract_int (dim
, &dim_index
);
5944 dim_index
-= 1; /* Zero-base index. */
5948 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5951 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5954 dim_extent
= mpz_get_si (array
->shape
[i
]);
5955 dim_stride
= tmpstride
[i
];
5959 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5960 sstride
[n
] = tmpstride
[i
];
5961 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5965 done
= resultsize
<= 0;
5970 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5972 if (*src
&& gfc_compare_expr (*src
, value
, INTRINSIC_EQ
) == 0)
5974 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5985 while (!done
&& count
[n
] == extent
[n
])
5988 base
-= sstride
[n
] * extent
[n
];
5989 dest
-= dstride
[n
] * extent
[n
];
5992 if (n
< result
->rank
)
5994 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5995 times, we'd warn for the last iteration, because the
5996 array index will have already been incremented to the
5997 array sizes, and we can't tell that this must make
5998 the test against result->rank false, because ranks
5999 must not exceed GFC_MAX_DIMENSIONS. */
6000 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
6011 /* Place updated expression in result constructor. */
6012 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
6013 for (i
= 0; i
< resultsize
; ++i
)
6015 result_ctor
->expr
= resultvec
[i
];
6016 result_ctor
= gfc_constructor_next (result_ctor
);
6024 /* Simplify findloc. */
6027 gfc_simplify_findloc (gfc_expr
*array
, gfc_expr
*value
, gfc_expr
*dim
,
6028 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
6032 bool back_val
= false;
6034 if (!is_constant_array_expr (array
)
6035 || array
->shape
== NULL
6036 || !gfc_is_constant_expr (dim
))
6039 if (! gfc_is_constant_expr (value
))
6043 && !is_constant_array_expr (mask
)
6044 && mask
->expr_type
!= EXPR_CONSTANT
)
6049 if (gfc_extract_int (kind
, &ikind
, -1))
6053 ikind
= gfc_default_integer_kind
;
6057 if (back
->expr_type
!= EXPR_CONSTANT
)
6060 back_val
= back
->value
.logical
;
6065 result
= transformational_result (array
, dim
, BT_INTEGER
,
6066 ikind
, &array
->where
);
6067 init_result_expr (result
, 0, array
);
6069 if (array
->rank
== 1)
6070 return simplify_findloc_to_scalar (result
, array
, value
, mask
,
6073 return simplify_findloc_to_array (result
, array
, value
, dim
, mask
,
6078 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
6079 return simplify_findloc_nodim (result
, value
, array
, mask
, back_val
);
6085 gfc_simplify_maxexponent (gfc_expr
*x
)
6087 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
6088 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
6089 gfc_real_kinds
[i
].max_exponent
);
6094 gfc_simplify_minexponent (gfc_expr
*x
)
6096 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
6097 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
6098 gfc_real_kinds
[i
].min_exponent
);
6103 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
6108 /* First check p. */
6109 if (p
->expr_type
!= EXPR_CONSTANT
)
6112 /* p shall not be 0. */
6116 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
6118 gfc_error ("Argument %qs of MOD at %L shall not be zero",
6120 return &gfc_bad_expr
;
6124 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
6126 gfc_error ("Argument %qs of MOD at %L shall not be zero",
6128 return &gfc_bad_expr
;
6132 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6135 if (a
->expr_type
!= EXPR_CONSTANT
)
6138 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6139 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6141 if (a
->ts
.type
== BT_INTEGER
)
6142 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6145 gfc_set_model_kind (kind
);
6146 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6150 return range_check (result
, "MOD");
6155 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
6160 /* First check p. */
6161 if (p
->expr_type
!= EXPR_CONSTANT
)
6164 /* p shall not be 0. */
6168 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
6170 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6172 return &gfc_bad_expr
;
6176 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
6178 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6180 return &gfc_bad_expr
;
6184 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6187 if (a
->expr_type
!= EXPR_CONSTANT
)
6190 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
6191 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
6193 if (a
->ts
.type
== BT_INTEGER
)
6194 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
6197 gfc_set_model_kind (kind
);
6198 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
6200 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
6202 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
6203 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
6207 mpfr_copysign (result
->value
.real
, result
->value
.real
,
6208 p
->value
.real
, GFC_RND_MODE
);
6211 return range_check (result
, "MODULO");
6216 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
6219 mpfr_exp_t emin
, emax
;
6222 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
6225 result
= gfc_copy_expr (x
);
6227 /* Save current values of emin and emax. */
6228 emin
= mpfr_get_emin ();
6229 emax
= mpfr_get_emax ();
6231 /* Set emin and emax for the current model number. */
6232 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
6233 mpfr_set_emin ((mpfr_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
6234 mpfr_get_prec(result
->value
.real
) + 1);
6235 mpfr_set_emax ((mpfr_exp_t
) gfc_real_kinds
[kind
].max_exponent
);
6236 mpfr_check_range (result
->value
.real
, 0, MPFR_RNDU
);
6238 if (mpfr_sgn (s
->value
.real
) > 0)
6240 mpfr_nextabove (result
->value
.real
);
6241 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDU
);
6245 mpfr_nextbelow (result
->value
.real
);
6246 mpfr_subnormalize (result
->value
.real
, 0, MPFR_RNDD
);
6249 mpfr_set_emin (emin
);
6250 mpfr_set_emax (emax
);
6252 /* Only NaN can occur. Do not use range check as it gives an
6253 error for denormal numbers. */
6254 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
6256 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
6257 gfc_free_expr (result
);
6258 return &gfc_bad_expr
;
6266 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
6268 gfc_expr
*itrunc
, *result
;
6271 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
6273 return &gfc_bad_expr
;
6275 if (e
->expr_type
!= EXPR_CONSTANT
)
6278 itrunc
= gfc_copy_expr (e
);
6279 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
6281 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
6282 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
6284 gfc_free_expr (itrunc
);
6286 return range_check (result
, name
);
6291 gfc_simplify_new_line (gfc_expr
*e
)
6295 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
6296 result
->value
.character
.string
[0] = '\n';
6303 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
6305 return simplify_nint ("NINT", e
, k
);
6310 gfc_simplify_idnint (gfc_expr
*e
)
6312 return simplify_nint ("IDNINT", e
, NULL
);
6315 static int norm2_scale
;
6318 norm2_add_squared (gfc_expr
*result
, gfc_expr
*e
)
6322 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6323 gcc_assert (result
->ts
.type
== BT_REAL
6324 && result
->expr_type
== EXPR_CONSTANT
);
6326 gfc_set_model_kind (result
->ts
.kind
);
6327 int index
= gfc_validate_kind (BT_REAL
, result
->ts
.kind
, false);
6329 if (mpfr_regular_p (result
->value
.real
))
6331 exp
= mpfr_get_exp (result
->value
.real
);
6332 /* If result is getting close to overflowing, scale down. */
6333 if (exp
>= gfc_real_kinds
[index
].max_exponent
- 4
6334 && norm2_scale
<= gfc_real_kinds
[index
].max_exponent
- 2)
6337 mpfr_div_ui (result
->value
.real
, result
->value
.real
, 16,
6343 if (mpfr_regular_p (e
->value
.real
))
6345 exp
= mpfr_get_exp (e
->value
.real
);
6346 /* If e**2 would overflow or close to overflowing, scale down. */
6347 if (exp
- norm2_scale
>= gfc_real_kinds
[index
].max_exponent
/ 2 - 2)
6349 int new_scale
= gfc_real_kinds
[index
].max_exponent
/ 2 + 4;
6350 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6351 mpfr_set_exp (tmp
, new_scale
- norm2_scale
);
6352 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6353 mpfr_div (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6354 norm2_scale
= new_scale
;
6359 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6360 mpfr_set_exp (tmp
, norm2_scale
);
6361 mpfr_div (tmp
, e
->value
.real
, tmp
, GFC_RND_MODE
);
6364 mpfr_set (tmp
, e
->value
.real
, GFC_RND_MODE
);
6365 mpfr_pow_ui (tmp
, tmp
, 2, GFC_RND_MODE
);
6366 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
6375 norm2_do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
6377 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6378 gcc_assert (result
->ts
.type
== BT_REAL
6379 && result
->expr_type
== EXPR_CONSTANT
);
6382 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6383 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6384 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6388 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6389 mpfr_set_exp (tmp
, norm2_scale
);
6390 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6400 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
6405 size_zero
= gfc_is_size_zero_array (e
);
6407 if (!(is_constant_array_expr (e
) || size_zero
)
6408 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
6411 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6412 init_result_expr (result
, 0, NULL
);
6418 if (!dim
|| e
->rank
== 1)
6420 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
6422 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6423 if (norm2_scale
&& mpfr_regular_p (result
->value
.real
))
6427 mpfr_set_ui (tmp
, 1, GFC_RND_MODE
);
6428 mpfr_set_exp (tmp
, norm2_scale
);
6429 mpfr_mul (result
->value
.real
, result
->value
.real
, tmp
, GFC_RND_MODE
);
6435 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
6444 gfc_simplify_not (gfc_expr
*e
)
6448 if (e
->expr_type
!= EXPR_CONSTANT
)
6451 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6452 mpz_com (result
->value
.integer
, e
->value
.integer
);
6454 return range_check (result
, "NOT");
6459 gfc_simplify_null (gfc_expr
*mold
)
6465 result
= gfc_copy_expr (mold
);
6466 result
->expr_type
= EXPR_NULL
;
6469 result
= gfc_get_null_expr (NULL
);
6476 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
6480 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6482 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6483 return &gfc_bad_expr
;
6486 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6489 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
6492 /* FIXME: gfc_current_locus is wrong. */
6493 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6494 &gfc_current_locus
);
6496 if (failed
&& failed
->value
.logical
!= 0)
6497 mpz_set_si (result
->value
.integer
, 0);
6499 mpz_set_si (result
->value
.integer
, 1);
6506 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
6511 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6514 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6519 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6520 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6521 return range_check (result
, "OR");
6524 return gfc_get_logical_expr (kind
, &x
->where
,
6525 x
->value
.logical
|| y
->value
.logical
);
6533 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
6536 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
6538 if (!is_constant_array_expr (array
)
6539 || !is_constant_array_expr (vector
)
6540 || (!gfc_is_constant_expr (mask
)
6541 && !is_constant_array_expr (mask
)))
6544 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
6545 if (array
->ts
.type
== BT_DERIVED
)
6546 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
6548 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
6549 vector_ctor
= vector
6550 ? gfc_constructor_first (vector
->value
.constructor
)
6553 if (mask
->expr_type
== EXPR_CONSTANT
6554 && mask
->value
.logical
)
6556 /* Copy all elements of ARRAY to RESULT. */
6559 gfc_constructor_append_expr (&result
->value
.constructor
,
6560 gfc_copy_expr (array_ctor
->expr
),
6563 array_ctor
= gfc_constructor_next (array_ctor
);
6564 vector_ctor
= gfc_constructor_next (vector_ctor
);
6567 else if (mask
->expr_type
== EXPR_ARRAY
)
6569 /* Copy only those elements of ARRAY to RESULT whose
6570 MASK equals .TRUE.. */
6571 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6572 while (mask_ctor
&& array_ctor
)
6574 if (mask_ctor
->expr
->value
.logical
)
6576 gfc_constructor_append_expr (&result
->value
.constructor
,
6577 gfc_copy_expr (array_ctor
->expr
),
6579 vector_ctor
= gfc_constructor_next (vector_ctor
);
6582 array_ctor
= gfc_constructor_next (array_ctor
);
6583 mask_ctor
= gfc_constructor_next (mask_ctor
);
6587 /* Append any left-over elements from VECTOR to RESULT. */
6590 gfc_constructor_append_expr (&result
->value
.constructor
,
6591 gfc_copy_expr (vector_ctor
->expr
),
6593 vector_ctor
= gfc_constructor_next (vector_ctor
);
6596 result
->shape
= gfc_get_shape (1);
6597 gfc_array_size (result
, &result
->shape
[0]);
6599 if (array
->ts
.type
== BT_CHARACTER
)
6600 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
6607 do_xor (gfc_expr
*result
, gfc_expr
*e
)
6609 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
6610 gcc_assert (result
->ts
.type
== BT_LOGICAL
6611 && result
->expr_type
== EXPR_CONSTANT
);
6613 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
6619 gfc_simplify_is_contiguous (gfc_expr
*array
)
6621 if (gfc_is_simply_contiguous (array
, false, true))
6622 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 1);
6624 if (gfc_is_not_contiguous (array
))
6625 return gfc_get_logical_expr (gfc_default_logical_kind
, &array
->where
, 0);
6632 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
6634 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
6639 gfc_simplify_popcnt (gfc_expr
*e
)
6644 if (e
->expr_type
!= EXPR_CONSTANT
)
6647 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6649 /* Convert argument to unsigned, then count the '1' bits. */
6650 mpz_init_set (x
, e
->value
.integer
);
6651 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
6652 res
= mpz_popcount (x
);
6655 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
6660 gfc_simplify_poppar (gfc_expr
*e
)
6665 if (e
->expr_type
!= EXPR_CONSTANT
)
6668 popcnt
= gfc_simplify_popcnt (e
);
6669 gcc_assert (popcnt
);
6671 bool fail
= gfc_extract_int (popcnt
, &i
);
6674 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
6679 gfc_simplify_precision (gfc_expr
*e
)
6681 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6682 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
6683 gfc_real_kinds
[i
].precision
);
6688 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6690 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
6695 gfc_simplify_radix (gfc_expr
*e
)
6698 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6703 i
= gfc_integer_kinds
[i
].radix
;
6707 i
= gfc_real_kinds
[i
].radix
;
6714 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6719 gfc_simplify_range (gfc_expr
*e
)
6722 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6727 i
= gfc_integer_kinds
[i
].range
;
6732 i
= gfc_real_kinds
[i
].range
;
6739 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6744 gfc_simplify_rank (gfc_expr
*e
)
6750 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
6755 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
6757 gfc_expr
*result
= NULL
;
6758 int kind
, tmp1
, tmp2
;
6760 /* Convert BOZ to real, and return without range checking. */
6761 if (e
->ts
.type
== BT_BOZ
)
6763 /* Determine kind for conversion of the BOZ. */
6765 gfc_extract_int (k
, &kind
);
6767 kind
= gfc_default_real_kind
;
6769 if (!gfc_boz2real (e
, kind
))
6771 result
= gfc_copy_expr (e
);
6775 if (e
->ts
.type
== BT_COMPLEX
)
6776 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
6778 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
6781 return &gfc_bad_expr
;
6783 if (e
->expr_type
!= EXPR_CONSTANT
)
6786 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
6788 tmp1
= warn_conversion
;
6789 tmp2
= warn_conversion_extra
;
6790 warn_conversion
= warn_conversion_extra
= 0;
6792 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
6794 warn_conversion
= tmp1
;
6795 warn_conversion_extra
= tmp2
;
6797 if (result
== &gfc_bad_expr
)
6798 return &gfc_bad_expr
;
6800 return range_check (result
, "REAL");
6805 gfc_simplify_realpart (gfc_expr
*e
)
6809 if (e
->expr_type
!= EXPR_CONSTANT
)
6812 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6813 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
6815 return range_check (result
, "REALPART");
6819 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
6824 bool have_length
= false;
6826 /* If NCOPIES isn't a constant, there's nothing we can do. */
6827 if (n
->expr_type
!= EXPR_CONSTANT
)
6830 /* If NCOPIES is negative, it's an error. */
6831 if (mpz_sgn (n
->value
.integer
) < 0)
6833 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6835 return &gfc_bad_expr
;
6838 /* If we don't know the character length, we can do no more. */
6839 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
6840 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6842 len
= gfc_mpz_get_hwi (e
->ts
.u
.cl
->length
->value
.integer
);
6845 else if (e
->expr_type
== EXPR_CONSTANT
6846 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
6848 len
= e
->value
.character
.length
;
6853 /* If the source length is 0, any value of NCOPIES is valid
6854 and everything behaves as if NCOPIES == 0. */
6857 mpz_set_ui (ncopies
, 0);
6859 mpz_set (ncopies
, n
->value
.integer
);
6861 /* Check that NCOPIES isn't too large. */
6867 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6869 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6873 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
6874 e
->ts
.u
.cl
->length
->value
.integer
);
6879 gfc_mpz_set_hwi (mlen
, len
);
6880 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
6884 /* The check itself. */
6885 if (mpz_cmp (ncopies
, max
) > 0)
6888 mpz_clear (ncopies
);
6889 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6891 return &gfc_bad_expr
;
6896 mpz_clear (ncopies
);
6898 /* For further simplification, we need the character string to be
6900 if (e
->expr_type
!= EXPR_CONSTANT
)
6905 (e
->ts
.u
.cl
->length
&&
6906 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
) != 0))
6908 bool fail
= gfc_extract_hwi (n
, &ncop
);
6915 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
6917 len
= e
->value
.character
.length
;
6918 gfc_charlen_t nlen
= ncop
* len
;
6920 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6921 (2**28 elements * 4 bytes (wide chars) per element) defer to
6922 runtime instead of consuming (unbounded) memory and CPU at
6924 if (nlen
> 268435456)
6926 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6927 " deferred to runtime, expect bugs", &e
->where
);
6931 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
6932 for (size_t i
= 0; i
< (size_t) ncop
; i
++)
6933 for (size_t j
= 0; j
< (size_t) len
; j
++)
6934 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
6936 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
6941 /* This one is a bear, but mainly has to do with shuffling elements. */
6944 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
6945 gfc_expr
*pad
, gfc_expr
*order_exp
)
6947 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
6948 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
6952 gfc_expr
*e
, *result
;
6953 bool zerosize
= false;
6955 /* Check that argument expression types are OK. */
6956 if (!is_constant_array_expr (source
)
6957 || !is_constant_array_expr (shape_exp
)
6958 || !is_constant_array_expr (pad
)
6959 || !is_constant_array_expr (order_exp
))
6962 if (source
->shape
== NULL
)
6965 /* Proceed with simplification, unpacking the array. */
6970 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
6975 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
6979 gfc_extract_int (e
, &shape
[rank
]);
6981 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
6982 if (shape
[rank
] < 0)
6984 gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
6985 "negative value %d for dimension %d",
6986 &shape_exp
->where
, shape
[rank
], rank
+1);
6988 return &gfc_bad_expr
;
6994 gcc_assert (rank
> 0);
6996 /* Now unpack the order array if present. */
6997 if (order_exp
== NULL
)
6999 for (i
= 0; i
< rank
; i
++)
7005 int order_size
, shape_size
;
7007 if (order_exp
->rank
!= shape_exp
->rank
)
7009 gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
7010 &order_exp
->where
, &shape_exp
->where
);
7012 return &gfc_bad_expr
;
7015 gfc_array_size (shape_exp
, &size
);
7016 shape_size
= mpz_get_ui (size
);
7018 gfc_array_size (order_exp
, &size
);
7019 order_size
= mpz_get_ui (size
);
7021 if (order_size
!= shape_size
)
7023 gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
7024 &order_exp
->where
, &shape_exp
->where
);
7026 return &gfc_bad_expr
;
7029 for (i
= 0; i
< rank
; i
++)
7031 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
7034 gfc_extract_int (e
, &order
[i
]);
7036 if (order
[i
] < 1 || order
[i
] > rank
)
7038 gfc_error ("Element with a value of %d in ORDER at %L must be "
7039 "in the range [1, ..., %d] for the RESHAPE intrinsic "
7040 "near %L", order
[i
], &order_exp
->where
, rank
,
7043 return &gfc_bad_expr
;
7047 if (x
[order
[i
]] != 0)
7049 gfc_error ("ORDER at %L is not a permutation of the size of "
7050 "SHAPE at %L", &order_exp
->where
, &shape_exp
->where
);
7052 return &gfc_bad_expr
;
7058 /* Count the elements in the source and padding arrays. */
7063 gfc_array_size (pad
, &size
);
7064 npad
= mpz_get_ui (size
);
7068 gfc_array_size (source
, &size
);
7069 nsource
= mpz_get_ui (size
);
7072 /* If it weren't for that pesky permutation we could just loop
7073 through the source and round out any shortage with pad elements.
7074 But no, someone just had to have the compiler do something the
7075 user should be doing. */
7077 for (i
= 0; i
< rank
; i
++)
7080 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7082 if (source
->ts
.type
== BT_DERIVED
)
7083 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7084 if (source
->ts
.type
== BT_CHARACTER
&& result
->ts
.u
.cl
== NULL
)
7085 result
->ts
= source
->ts
;
7086 result
->rank
= rank
;
7087 result
->shape
= gfc_get_shape (rank
);
7088 for (i
= 0; i
< rank
; i
++)
7090 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
7098 while (nsource
> 0 || npad
> 0)
7100 /* Figure out which element to extract. */
7101 mpz_set_ui (index
, 0);
7103 for (i
= rank
- 1; i
>= 0; i
--)
7105 mpz_add_ui (index
, index
, x
[order
[i
]]);
7107 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
7110 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
7111 gfc_internal_error ("Reshaped array too large at %C");
7113 j
= mpz_get_ui (index
);
7116 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
7123 gfc_error ("Without padding, there are not enough elements "
7124 "in the intrinsic RESHAPE source at %L to match "
7125 "the shape", &source
->where
);
7126 gfc_free_expr (result
);
7131 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
7135 gfc_constructor_append_expr (&result
->value
.constructor
,
7136 gfc_copy_expr (e
), &e
->where
);
7138 /* Calculate the next element. */
7142 if (++x
[i
] < shape
[i
])
7160 gfc_simplify_rrspacing (gfc_expr
*x
)
7166 if (x
->expr_type
!= EXPR_CONSTANT
)
7169 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7171 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7173 /* RRSPACING(+/- 0.0) = 0.0 */
7174 if (mpfr_zero_p (x
->value
.real
))
7176 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7180 /* RRSPACING(inf) = NaN */
7181 if (mpfr_inf_p (x
->value
.real
))
7183 mpfr_set_nan (result
->value
.real
);
7187 /* RRSPACING(NaN) = same NaN */
7188 if (mpfr_nan_p (x
->value
.real
))
7190 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7194 /* | x * 2**(-e) | * 2**p. */
7195 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7196 e
= - (long int) mpfr_get_exp (x
->value
.real
);
7197 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
7199 p
= (long int) gfc_real_kinds
[i
].digits
;
7200 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
7202 return range_check (result
, "RRSPACING");
7207 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
7209 int k
, neg_flag
, power
, exp_range
;
7210 mpfr_t scale
, radix
;
7213 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7216 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7218 if (mpfr_zero_p (x
->value
.real
))
7220 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7224 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
7226 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
7228 /* This check filters out values of i that would overflow an int. */
7229 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
7230 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
7232 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
7233 gfc_free_expr (result
);
7234 return &gfc_bad_expr
;
7237 /* Compute scale = radix ** power. */
7238 power
= mpz_get_si (i
->value
.integer
);
7248 gfc_set_model_kind (x
->ts
.kind
);
7251 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
7252 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
7255 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7257 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
7259 mpfr_clears (scale
, radix
, NULL
);
7261 return range_check (result
, "SCALE");
7265 /* Variants of strspn and strcspn that operate on wide characters. */
7268 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7271 const gfc_char_t
*c
;
7275 for (c
= s2
; *c
; c
++)
7289 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
7292 const gfc_char_t
*c
;
7296 for (c
= s2
; *c
; c
++)
7311 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
7316 size_t indx
, len
, lenc
;
7317 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
7320 return &gfc_bad_expr
;
7322 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
7323 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
7326 if (b
!= NULL
&& b
->value
.logical
!= 0)
7331 len
= e
->value
.character
.length
;
7332 lenc
= c
->value
.character
.length
;
7334 if (len
== 0 || lenc
== 0)
7342 indx
= wide_strcspn (e
->value
.character
.string
,
7343 c
->value
.character
.string
) + 1;
7348 for (indx
= len
; indx
> 0; indx
--)
7350 for (i
= 0; i
< lenc
; i
++)
7352 if (c
->value
.character
.string
[i
]
7353 == e
->value
.character
.string
[indx
- 1])
7361 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
7362 return range_check (result
, "SCAN");
7367 gfc_simplify_selected_char_kind (gfc_expr
*e
)
7371 if (e
->expr_type
!= EXPR_CONSTANT
)
7374 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
7375 || gfc_compare_with_Cstring (e
, "default", false) == 0)
7377 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
7382 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7387 gfc_simplify_selected_int_kind (gfc_expr
*e
)
7391 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
))
7396 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
7397 if (gfc_integer_kinds
[i
].range
>= range
7398 && gfc_integer_kinds
[i
].kind
< kind
)
7399 kind
= gfc_integer_kinds
[i
].kind
;
7401 if (kind
== INT_MAX
)
7404 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7409 gfc_simplify_selected_logical_kind (gfc_expr
*e
)
7413 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &bits
))
7418 for (i
= 0; gfc_logical_kinds
[i
].kind
!= 0; i
++)
7419 if (gfc_logical_kinds
[i
].bit_size
>= bits
7420 && gfc_logical_kinds
[i
].kind
< kind
)
7421 kind
= gfc_logical_kinds
[i
].kind
;
7423 if (kind
== INT_MAX
)
7426 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
7431 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
7433 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
7435 locus
*loc
= &gfc_current_locus
;
7441 if (p
->expr_type
!= EXPR_CONSTANT
7442 || gfc_extract_int (p
, &precision
))
7451 if (q
->expr_type
!= EXPR_CONSTANT
7452 || gfc_extract_int (q
, &range
))
7463 if (rdx
->expr_type
!= EXPR_CONSTANT
7464 || gfc_extract_int (rdx
, &radix
))
7472 found_precision
= 0;
7476 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
7478 if (gfc_real_kinds
[i
].precision
>= precision
)
7479 found_precision
= 1;
7481 if (gfc_real_kinds
[i
].range
>= range
)
7484 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7487 if (gfc_real_kinds
[i
].precision
>= precision
7488 && gfc_real_kinds
[i
].range
>= range
7489 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7490 && gfc_real_kinds
[i
].kind
< kind
)
7491 kind
= gfc_real_kinds
[i
].kind
;
7494 if (kind
== INT_MAX
)
7496 if (found_radix
&& found_range
&& !found_precision
)
7498 else if (found_radix
&& found_precision
&& !found_range
)
7500 else if (found_radix
&& !found_precision
&& !found_range
)
7502 else if (found_radix
)
7508 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
7513 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
7516 mpfr_t exp
, absv
, log2
, pow2
, frac
;
7519 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7522 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7524 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7525 SET_EXPONENT (NaN) = same NaN */
7526 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
7528 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7532 /* SET_EXPONENT (inf) = NaN */
7533 if (mpfr_inf_p (x
->value
.real
))
7535 mpfr_set_nan (result
->value
.real
);
7539 gfc_set_model_kind (x
->ts
.kind
);
7546 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
7547 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
7549 mpfr_floor (log2
, log2
);
7550 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
7552 /* Old exponent value, and fraction. */
7553 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
7555 mpfr_div (frac
, x
->value
.real
, pow2
, GFC_RND_MODE
);
7558 exp2
= mpz_get_si (i
->value
.integer
);
7559 mpfr_mul_2si (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
7561 mpfr_clears (absv
, log2
, exp
, pow2
, frac
, NULL
);
7563 return range_check (result
, "SET_EXPONENT");
7568 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
7570 mpz_t shape
[GFC_MAX_DIMENSIONS
];
7571 gfc_expr
*result
, *e
, *f
;
7575 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
7577 if (source
->rank
== -1)
7580 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
7581 result
->shape
= gfc_get_shape (1);
7582 mpz_init (result
->shape
[0]);
7584 if (source
->rank
== 0)
7587 if (source
->expr_type
== EXPR_VARIABLE
)
7589 ar
= gfc_find_array_ref (source
);
7590 t
= gfc_array_ref_shape (ar
, shape
);
7592 else if (source
->shape
)
7595 for (n
= 0; n
< source
->rank
; n
++)
7597 mpz_init (shape
[n
]);
7598 mpz_set (shape
[n
], source
->shape
[n
]);
7604 for (n
= 0; n
< source
->rank
; n
++)
7606 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
7609 mpz_set (e
->value
.integer
, shape
[n
]);
7612 mpz_set_ui (e
->value
.integer
, n
+ 1);
7614 f
= simplify_size (source
, e
, k
);
7618 gfc_free_expr (result
);
7625 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
7627 gfc_free_expr (result
);
7629 gfc_clear_shape (shape
, source
->rank
);
7630 return &gfc_bad_expr
;
7633 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
7637 gfc_clear_shape (shape
, source
->rank
);
7639 mpz_set_si (result
->shape
[0], source
->rank
);
7646 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
7649 gfc_expr
*return_value
;
7653 /* For unary operations, the size of the result is given by the size
7654 of the operand. For binary ones, it's the size of the first operand
7655 unless it is scalar, then it is the size of the second. */
7656 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
7658 gfc_expr
* replacement
;
7659 gfc_expr
* simplified
;
7661 switch (array
->value
.op
.op
)
7663 /* Unary operations. */
7665 case INTRINSIC_UPLUS
:
7666 case INTRINSIC_UMINUS
:
7667 case INTRINSIC_PARENTHESES
:
7668 replacement
= array
->value
.op
.op1
;
7671 /* Binary operations. If any one of the operands is scalar, take
7672 the other one's size. If both of them are arrays, it does not
7673 matter -- try to find one with known shape, if possible. */
7675 if (array
->value
.op
.op1
->rank
== 0)
7676 replacement
= array
->value
.op
.op2
;
7677 else if (array
->value
.op
.op2
->rank
== 0)
7678 replacement
= array
->value
.op
.op1
;
7681 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
7685 replacement
= array
->value
.op
.op2
;
7690 /* Try to reduce it directly if possible. */
7691 simplified
= simplify_size (replacement
, dim
, k
);
7693 /* Otherwise, we build a new SIZE call. This is hopefully at least
7694 simpler than the original one. */
7697 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
7698 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
7699 GFC_ISYM_SIZE
, "size",
7701 gfc_copy_expr (replacement
),
7702 gfc_copy_expr (dim
),
7708 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
7709 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
7710 && !gfc_resolve_array_spec (ref
->u
.ar
.as
, 0))
7715 if (!gfc_array_size (array
, &size
))
7720 if (dim
->expr_type
!= EXPR_CONSTANT
)
7723 if (array
->rank
== -1)
7726 d
= mpz_get_si (dim
->value
.integer
) - 1;
7727 if (d
< 0 || d
> array
->rank
- 1)
7729 gfc_error ("DIM argument (%d) to intrinsic SIZE at %L out of range "
7730 "(1:%d)", d
+1, &array
->where
, array
->rank
);
7731 return &gfc_bad_expr
;
7734 if (!gfc_array_dimen_size (array
, d
, &size
))
7738 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
7739 mpz_set (return_value
->value
.integer
, size
);
7742 return return_value
;
7747 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
7750 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
7753 return &gfc_bad_expr
;
7755 result
= simplify_size (array
, dim
, k
);
7756 if (result
== NULL
|| result
== &gfc_bad_expr
)
7759 return range_check (result
, "SIZE");
7763 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
7764 multiplied by the array size. */
7767 gfc_simplify_sizeof (gfc_expr
*x
)
7769 gfc_expr
*result
= NULL
;
7773 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7776 if (x
->ts
.type
== BT_CHARACTER
7777 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7778 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7781 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
)
7783 if (!gfc_array_size (x
, &array_size
))
7786 mpz_clear (array_size
);
7789 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
7791 gfc_target_expr_size (x
, &res_size
);
7792 mpz_set_si (result
->value
.integer
, res_size
);
7798 /* STORAGE_SIZE returns the size in bits of a single array element. */
7801 gfc_simplify_storage_size (gfc_expr
*x
,
7804 gfc_expr
*result
= NULL
;
7808 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7811 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
7812 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7813 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7816 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
7818 return &gfc_bad_expr
;
7820 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
7822 gfc_element_size (x
, &siz
);
7823 mpz_set_si (result
->value
.integer
, siz
);
7824 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
7826 return range_check (result
, "STORAGE_SIZE");
7831 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
7835 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
7838 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7843 mpz_abs (result
->value
.integer
, x
->value
.integer
);
7844 if (mpz_sgn (y
->value
.integer
) < 0)
7845 mpz_neg (result
->value
.integer
, result
->value
.integer
);
7850 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
7853 mpfr_setsign (result
->value
.real
, x
->value
.real
,
7854 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
7858 gfc_internal_error ("Bad type in gfc_simplify_sign");
7866 gfc_simplify_sin (gfc_expr
*x
)
7870 if (x
->expr_type
!= EXPR_CONSTANT
)
7873 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7878 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7882 gfc_set_model (x
->value
.real
);
7883 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7887 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
7890 return range_check (result
, "SIN");
7895 gfc_simplify_sinh (gfc_expr
*x
)
7899 if (x
->expr_type
!= EXPR_CONSTANT
)
7902 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7907 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7911 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7918 return range_check (result
, "SINH");
7922 /* The argument is always a double precision real that is converted to
7923 single precision. TODO: Rounding! */
7926 gfc_simplify_sngl (gfc_expr
*a
)
7931 if (a
->expr_type
!= EXPR_CONSTANT
)
7934 /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
7936 tmp1
= warn_conversion
;
7937 tmp2
= warn_conversion_extra
;
7938 warn_conversion
= warn_conversion_extra
= 0;
7940 result
= gfc_real2real (a
, gfc_default_real_kind
);
7942 warn_conversion
= tmp1
;
7943 warn_conversion_extra
= tmp2
;
7945 return range_check (result
, "SNGL");
7950 gfc_simplify_spacing (gfc_expr
*x
)
7956 if (x
->expr_type
!= EXPR_CONSTANT
)
7959 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7960 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7962 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
7963 if (mpfr_zero_p (x
->value
.real
))
7965 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
7969 /* SPACING(inf) = NaN */
7970 if (mpfr_inf_p (x
->value
.real
))
7972 mpfr_set_nan (result
->value
.real
);
7976 /* SPACING(NaN) = same NaN */
7977 if (mpfr_nan_p (x
->value
.real
))
7979 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7983 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
7984 are the radix, exponent of x, and precision. This excludes the
7985 possibility of subnormal numbers. Fortran 2003 states the result is
7986 b**max(e - p, emin - 1). */
7988 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
7989 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
7990 en
= en
> ep
? en
: ep
;
7992 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
7993 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
7995 return range_check (result
, "SPACING");
8000 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
8002 gfc_expr
*result
= NULL
;
8003 int nelem
, i
, j
, dim
, ncopies
;
8006 if ((!gfc_is_constant_expr (source
)
8007 && !is_constant_array_expr (source
))
8008 || !gfc_is_constant_expr (dim_expr
)
8009 || !gfc_is_constant_expr (ncopies_expr
))
8012 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
8013 gfc_extract_int (dim_expr
, &dim
);
8014 dim
-= 1; /* zero-base DIM */
8016 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
8017 gfc_extract_int (ncopies_expr
, &ncopies
);
8018 ncopies
= MAX (ncopies
, 0);
8020 /* Do not allow the array size to exceed the limit for an array
8022 if (source
->expr_type
== EXPR_ARRAY
)
8024 if (!gfc_array_size (source
, &size
))
8025 gfc_internal_error ("Failure getting length of a constant array.");
8028 mpz_init_set_ui (size
, 1);
8030 nelem
= mpz_get_si (size
) * ncopies
;
8031 if (nelem
> flag_max_array_constructor
)
8033 if (gfc_init_expr_flag
)
8035 gfc_error ("The number of elements (%d) in the array constructor "
8036 "at %L requires an increase of the allowed %d upper "
8037 "limit. See %<-fmax-array-constructor%> option.",
8038 nelem
, &source
->where
, flag_max_array_constructor
);
8039 return &gfc_bad_expr
;
8045 if (source
->expr_type
== EXPR_CONSTANT
8046 || source
->expr_type
== EXPR_STRUCTURE
)
8048 gcc_assert (dim
== 0);
8050 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
8052 if (source
->ts
.type
== BT_DERIVED
)
8053 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
8055 result
->shape
= gfc_get_shape (result
->rank
);
8056 mpz_init_set_si (result
->shape
[0], ncopies
);
8058 for (i
= 0; i
< ncopies
; ++i
)
8059 gfc_constructor_append_expr (&result
->value
.constructor
,
8060 gfc_copy_expr (source
), NULL
);
8062 else if (source
->expr_type
== EXPR_ARRAY
)
8064 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
8065 gfc_constructor
*source_ctor
;
8067 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
8068 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
8070 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
8072 if (source
->ts
.type
== BT_DERIVED
)
8073 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
8074 result
->rank
= source
->rank
+ 1;
8075 result
->shape
= gfc_get_shape (result
->rank
);
8077 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
8080 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
8082 mpz_init_set_si (result
->shape
[i
], ncopies
);
8084 extent
[i
] = mpz_get_si (result
->shape
[i
]);
8085 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
8089 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
8090 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
8092 for (i
= 0; i
< ncopies
; ++i
)
8093 gfc_constructor_insert_expr (&result
->value
.constructor
,
8094 gfc_copy_expr (source_ctor
->expr
),
8095 NULL
, offset
+ i
* rstride
[dim
]);
8097 offset
+= (dim
== 0 ? ncopies
: 1);
8102 gfc_error ("Simplification of SPREAD at %C not yet implemented");
8103 return &gfc_bad_expr
;
8106 if (source
->ts
.type
== BT_CHARACTER
)
8107 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
8114 gfc_simplify_sqrt (gfc_expr
*e
)
8116 gfc_expr
*result
= NULL
;
8118 if (e
->expr_type
!= EXPR_CONSTANT
)
8124 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
8126 gfc_error ("Argument of SQRT at %L has a negative value",
8128 return &gfc_bad_expr
;
8130 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
8131 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
8135 gfc_set_model (e
->value
.real
);
8137 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
8138 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
8142 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
8145 return range_check (result
, "SQRT");
8150 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
8152 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
8156 /* Simplify COTAN(X) where X has the unit of radian. */
8159 gfc_simplify_cotan (gfc_expr
*x
)
8164 if (x
->expr_type
!= EXPR_CONSTANT
)
8167 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8172 mpfr_cot (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8176 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
8177 val
= &result
->value
.complex;
8178 mpc_init2 (swp
, mpfr_get_default_prec ());
8179 mpc_sin_cos (*val
, swp
, x
->value
.complex, GFC_MPC_RND_MODE
,
8181 mpc_div (*val
, swp
, *val
, GFC_MPC_RND_MODE
);
8189 return range_check (result
, "COTAN");
8194 gfc_simplify_tan (gfc_expr
*x
)
8198 if (x
->expr_type
!= EXPR_CONSTANT
)
8201 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8206 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8210 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8217 return range_check (result
, "TAN");
8222 gfc_simplify_tanh (gfc_expr
*x
)
8226 if (x
->expr_type
!= EXPR_CONSTANT
)
8229 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
8234 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
8238 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
8245 return range_check (result
, "TANH");
8250 gfc_simplify_tiny (gfc_expr
*e
)
8255 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
8257 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
8258 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
8265 gfc_simplify_trailz (gfc_expr
*e
)
8267 unsigned long tz
, bs
;
8270 if (e
->expr_type
!= EXPR_CONSTANT
)
8273 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
8274 bs
= gfc_integer_kinds
[i
].bit_size
;
8275 tz
= mpz_scan1 (e
->value
.integer
, 0);
8277 return gfc_get_int_expr (gfc_default_integer_kind
,
8278 &e
->where
, MIN (tz
, bs
));
8283 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
8286 gfc_expr
*mold_element
;
8291 unsigned char *buffer
;
8292 size_t result_length
;
8294 if (!gfc_is_constant_expr (source
) || !gfc_is_constant_expr (size
))
8297 if (!gfc_resolve_expr (mold
))
8299 if (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
8302 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
8303 &result_size
, &result_length
))
8306 /* Calculate the size of the source. */
8307 if (source
->expr_type
== EXPR_ARRAY
&& !gfc_array_size (source
, &tmp
))
8308 gfc_internal_error ("Failure getting length of a constant array.");
8310 /* Create an empty new expression with the appropriate characteristics. */
8311 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
8313 result
->ts
= mold
->ts
;
8315 mold_element
= (mold
->expr_type
== EXPR_ARRAY
&& mold
->value
.constructor
)
8316 ? gfc_constructor_first (mold
->value
.constructor
)->expr
8319 /* Set result character length, if needed. Note that this needs to be
8320 set even for array expressions, in order to pass this information into
8321 gfc_target_interpret_expr. */
8322 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
8324 result
->value
.character
.length
= mold_element
->value
.character
.length
;
8326 /* Let the typespec of the result inherit the string length.
8327 This is crucial if a resulting array has size zero. */
8328 if (mold_element
->ts
.u
.cl
->length
)
8329 result
->ts
.u
.cl
->length
= gfc_copy_expr (mold_element
->ts
.u
.cl
->length
);
8331 result
->ts
.u
.cl
->length
=
8332 gfc_get_int_expr (gfc_charlen_int_kind
, NULL
,
8333 mold_element
->value
.character
.length
);
8336 /* Set the number of elements in the result, and determine its size. */
8338 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
8340 result
->expr_type
= EXPR_ARRAY
;
8342 result
->shape
= gfc_get_shape (1);
8343 mpz_init_set_ui (result
->shape
[0], result_length
);
8348 /* Allocate the buffer to store the binary version of the source. */
8349 buffer_size
= MAX (source_size
, result_size
);
8350 buffer
= (unsigned char*)alloca (buffer_size
);
8351 memset (buffer
, 0, buffer_size
);
8353 /* Now write source to the buffer. */
8354 gfc_target_encode_expr (source
, buffer
, buffer_size
);
8356 /* And read the buffer back into the new expression. */
8357 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
8364 gfc_simplify_transpose (gfc_expr
*matrix
)
8366 int row
, matrix_rows
, col
, matrix_cols
;
8369 if (!is_constant_array_expr (matrix
))
8372 gcc_assert (matrix
->rank
== 2);
8374 if (matrix
->shape
== NULL
)
8377 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
8380 result
->shape
= gfc_get_shape (result
->rank
);
8381 mpz_init_set (result
->shape
[0], matrix
->shape
[1]);
8382 mpz_init_set (result
->shape
[1], matrix
->shape
[0]);
8384 if (matrix
->ts
.type
== BT_CHARACTER
)
8385 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
8386 else if (matrix
->ts
.type
== BT_DERIVED
)
8387 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
8389 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
8390 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
8391 for (row
= 0; row
< matrix_rows
; ++row
)
8392 for (col
= 0; col
< matrix_cols
; ++col
)
8394 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
8395 col
* matrix_rows
+ row
);
8396 gfc_constructor_insert_expr (&result
->value
.constructor
,
8397 gfc_copy_expr (e
), &matrix
->where
,
8398 row
* matrix_cols
+ col
);
8406 gfc_simplify_trim (gfc_expr
*e
)
8409 int count
, i
, len
, lentrim
;
8411 if (e
->expr_type
!= EXPR_CONSTANT
)
8414 len
= e
->value
.character
.length
;
8415 for (count
= 0, i
= 1; i
<= len
; ++i
)
8417 if (e
->value
.character
.string
[len
- i
] == ' ')
8423 lentrim
= len
- count
;
8425 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
8426 for (i
= 0; i
< lentrim
; i
++)
8427 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
8434 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
8439 gfc_constructor
*sub_cons
;
8443 if (!is_constant_array_expr (sub
))
8446 /* Follow any component references. */
8447 as
= coarray
->symtree
->n
.sym
->as
;
8448 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
8449 if (ref
->type
== REF_COMPONENT
)
8452 if (!as
|| as
->type
== AS_DEFERRED
)
8455 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
8456 the cosubscript addresses the first image. */
8458 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
8461 for (d
= 1; d
<= as
->corank
; d
++)
8466 gcc_assert (sub_cons
!= NULL
);
8468 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
8470 if (ca_bound
== NULL
)
8473 if (ca_bound
== &gfc_bad_expr
)
8476 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
8480 gfc_free_expr (ca_bound
);
8481 sub_cons
= gfc_constructor_next (sub_cons
);
8485 first_image
= false;
8489 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8490 "SUB has %ld and COARRAY lower bound is %ld)",
8492 mpz_get_si (sub_cons
->expr
->value
.integer
),
8493 mpz_get_si (ca_bound
->value
.integer
));
8494 gfc_free_expr (ca_bound
);
8495 return &gfc_bad_expr
;
8498 gfc_free_expr (ca_bound
);
8500 /* Check whether upperbound is valid for the multi-images case. */
8503 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
8505 if (ca_bound
== &gfc_bad_expr
)
8508 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
8509 && mpz_cmp (ca_bound
->value
.integer
,
8510 sub_cons
->expr
->value
.integer
) < 0)
8512 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
8513 "SUB has %ld and COARRAY upper bound is %ld)",
8515 mpz_get_si (sub_cons
->expr
->value
.integer
),
8516 mpz_get_si (ca_bound
->value
.integer
));
8517 gfc_free_expr (ca_bound
);
8518 return &gfc_bad_expr
;
8522 gfc_free_expr (ca_bound
);
8525 sub_cons
= gfc_constructor_next (sub_cons
);
8528 gcc_assert (sub_cons
== NULL
);
8530 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
8533 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8534 &gfc_current_locus
);
8536 mpz_set_si (result
->value
.integer
, 1);
8538 mpz_set_si (result
->value
.integer
, 0);
8544 gfc_simplify_image_status (gfc_expr
*image
, gfc_expr
*team ATTRIBUTE_UNUSED
)
8546 if (flag_coarray
== GFC_FCOARRAY_NONE
)
8548 gfc_current_locus
= *gfc_current_intrinsic_where
;
8549 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
8550 return &gfc_bad_expr
;
8553 /* Simplification is possible for fcoarray = single only. For all other modes
8554 the result depends on runtime conditions. */
8555 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8558 if (gfc_is_constant_expr (image
))
8561 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8563 if (mpz_get_si (image
->value
.integer
) == 1)
8564 mpz_set_si (result
->value
.integer
, 0);
8566 mpz_set_si (result
->value
.integer
, GFC_STAT_STOPPED_IMAGE
);
8575 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
8576 gfc_expr
*distance ATTRIBUTE_UNUSED
)
8578 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8581 /* If no coarray argument has been passed or when the first argument
8582 is actually a distance argument. */
8583 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
8586 /* FIXME: gfc_current_locus is wrong. */
8587 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8588 &gfc_current_locus
);
8589 mpz_set_si (result
->value
.integer
, 1);
8593 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
8594 return simplify_cobound (coarray
, dim
, NULL
, 0);
8599 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8601 return simplify_bound (array
, dim
, kind
, 1);
8605 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8607 return simplify_cobound (array
, dim
, kind
, 1);
8612 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
8614 gfc_expr
*result
, *e
;
8615 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
8617 if (!is_constant_array_expr (vector
)
8618 || !is_constant_array_expr (mask
)
8619 || (!gfc_is_constant_expr (field
)
8620 && !is_constant_array_expr (field
)))
8623 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
8625 if (vector
->ts
.type
== BT_DERIVED
)
8626 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
8627 result
->rank
= mask
->rank
;
8628 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
8630 if (vector
->ts
.type
== BT_CHARACTER
)
8631 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
8633 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
8634 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
8636 = field
->expr_type
== EXPR_ARRAY
8637 ? gfc_constructor_first (field
->value
.constructor
)
8642 if (mask_ctor
->expr
->value
.logical
)
8646 e
= gfc_copy_expr (vector_ctor
->expr
);
8647 vector_ctor
= gfc_constructor_next (vector_ctor
);
8651 gfc_free_expr (result
);
8655 else if (field
->expr_type
== EXPR_ARRAY
)
8658 e
= gfc_copy_expr (field_ctor
->expr
);
8661 /* Not enough elements in array FIELD. */
8662 gfc_free_expr (result
);
8663 return &gfc_bad_expr
;
8667 e
= gfc_copy_expr (field
);
8669 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
8671 mask_ctor
= gfc_constructor_next (mask_ctor
);
8672 field_ctor
= gfc_constructor_next (field_ctor
);
8680 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
8684 size_t index
, len
, lenset
;
8686 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
8689 return &gfc_bad_expr
;
8691 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
8692 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
8695 if (b
!= NULL
&& b
->value
.logical
!= 0)
8700 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
8702 len
= s
->value
.character
.length
;
8703 lenset
= set
->value
.character
.length
;
8707 mpz_set_ui (result
->value
.integer
, 0);
8715 mpz_set_ui (result
->value
.integer
, 1);
8719 index
= wide_strspn (s
->value
.character
.string
,
8720 set
->value
.character
.string
) + 1;
8729 mpz_set_ui (result
->value
.integer
, len
);
8732 for (index
= len
; index
> 0; index
--)
8734 for (i
= 0; i
< lenset
; i
++)
8736 if (s
->value
.character
.string
[index
- 1]
8737 == set
->value
.character
.string
[i
])
8745 mpz_set_ui (result
->value
.integer
, index
);
8751 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
8756 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
8759 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
8764 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
8765 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
8766 return range_check (result
, "XOR");
8769 return gfc_get_logical_expr (kind
, &x
->where
,
8770 (x
->value
.logical
&& !y
->value
.logical
)
8771 || (!x
->value
.logical
&& y
->value
.logical
));
8779 /****************** Constant simplification *****************/
8781 /* Master function to convert one constant to another. While this is
8782 used as a simplification function, it requires the destination type
8783 and kind information which is supplied by a special case in
8787 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
8789 gfc_expr
*result
, *(*f
) (gfc_expr
*, int);
8790 gfc_constructor
*c
, *t
;
8804 f
= gfc_int2complex
;
8824 f
= gfc_real2complex
;
8835 f
= gfc_complex2int
;
8838 f
= gfc_complex2real
;
8841 f
= gfc_complex2complex
;
8867 f
= gfc_hollerith2int
;
8871 f
= gfc_hollerith2real
;
8875 f
= gfc_hollerith2complex
;
8879 f
= gfc_hollerith2character
;
8883 f
= gfc_hollerith2logical
;
8895 f
= gfc_character2int
;
8899 f
= gfc_character2real
;
8903 f
= gfc_character2complex
;
8907 f
= gfc_character2character
;
8911 f
= gfc_character2logical
;
8921 return &gfc_bad_expr
;
8926 switch (e
->expr_type
)
8929 result
= f (e
, kind
);
8931 return &gfc_bad_expr
;
8935 if (!gfc_is_constant_expr (e
))
8938 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8939 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8940 result
->rank
= e
->rank
;
8942 for (c
= gfc_constructor_first (e
->value
.constructor
);
8943 c
; c
= gfc_constructor_next (c
))
8946 if (c
->iterator
== NULL
)
8948 if (c
->expr
->expr_type
== EXPR_ARRAY
)
8949 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8950 else if (c
->expr
->expr_type
== EXPR_OP
)
8952 if (!gfc_simplify_expr (c
->expr
, 1))
8953 return &gfc_bad_expr
;
8954 tmp
= f (c
->expr
, kind
);
8957 tmp
= f (c
->expr
, kind
);
8960 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8962 if (tmp
== NULL
|| tmp
== &gfc_bad_expr
)
8964 gfc_free_expr (result
);
8968 t
= gfc_constructor_append_expr (&result
->value
.constructor
,
8971 t
->iterator
= gfc_copy_iterator (c
->iterator
);
8984 /* Function for converting character constants. */
8986 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
8991 if (!gfc_is_constant_expr (e
))
8994 if (e
->expr_type
== EXPR_CONSTANT
)
8996 /* Simple case of a scalar. */
8997 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
8999 return &gfc_bad_expr
;
9001 result
->value
.character
.length
= e
->value
.character
.length
;
9002 result
->value
.character
.string
9003 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
9004 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
9005 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
9007 /* Check we only have values representable in the destination kind. */
9008 for (i
= 0; i
< result
->value
.character
.length
; i
++)
9009 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
9012 gfc_error ("Character %qs in string at %L cannot be converted "
9013 "into character kind %d",
9014 gfc_print_wide_char (result
->value
.character
.string
[i
]),
9016 gfc_free_expr (result
);
9017 return &gfc_bad_expr
;
9022 else if (e
->expr_type
== EXPR_ARRAY
)
9024 /* For an array constructor, we convert each constructor element. */
9027 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
9028 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
9029 result
->rank
= e
->rank
;
9030 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
9032 for (c
= gfc_constructor_first (e
->value
.constructor
);
9033 c
; c
= gfc_constructor_next (c
))
9035 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
9036 if (tmp
== &gfc_bad_expr
)
9038 gfc_free_expr (result
);
9039 return &gfc_bad_expr
;
9044 gfc_free_expr (result
);
9048 gfc_constructor_append_expr (&result
->value
.constructor
,
9060 gfc_simplify_compiler_options (void)
9065 str
= gfc_get_option_string ();
9066 result
= gfc_get_character_expr (gfc_default_character_kind
,
9067 &gfc_current_locus
, str
, strlen (str
));
9074 gfc_simplify_compiler_version (void)
9079 len
= strlen ("GCC version ") + strlen (version_string
);
9080 buffer
= XALLOCAVEC (char, len
+ 1);
9081 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
9082 return gfc_get_character_expr (gfc_default_character_kind
,
9083 &gfc_current_locus
, buffer
, len
);
9086 /* Simplification routines for intrinsics of IEEE modules. */
9089 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
9091 gfc_actual_arglist
*arg
;
9092 gfc_expr
*p
= NULL
, *q
= NULL
, *rdx
= NULL
;
9094 arg
= expr
->value
.function
.actual
;
9098 q
= arg
->next
->expr
;
9099 if (arg
->next
->next
)
9100 rdx
= arg
->next
->next
->expr
;
9103 /* Currently, if IEEE is supported and this module is built, it means
9104 all our floating-point types conform to IEEE. Hence, we simply handle
9105 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
9106 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
9110 simplify_ieee_support (gfc_expr
*expr
)
9112 /* We consider that if the IEEE modules are loaded, we have full support
9113 for flags, halting and rounding, which are the three functions
9114 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
9115 expressions. One day, we will need libgfortran to detect support and
9116 communicate it back to us, allowing for partial support. */
9118 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
9123 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
9125 int n
= strlen(name
);
9127 if (!strncmp(sym
->name
, name
, n
))
9130 /* If a generic was used and renamed, we need more work to find out.
9131 Compare the specific name. */
9132 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
9139 gfc_simplify_ieee_functions (gfc_expr
*expr
)
9141 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
9143 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
9144 return simplify_ieee_selected_real_kind (expr
);
9145 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
9146 || matches_ieee_function_name(sym
, "ieee_support_halting")
9147 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
9148 return simplify_ieee_support (expr
);