1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2018 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);
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. */
173 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
178 /* Converts an mpz_t unsigned variable into a signed one, assuming
179 two's complement representations and a binary width of bitsize.
180 If the bitsize-1 bit is set, this is taken as a sign bit and
181 the number is converted to the corresponding negative number. */
184 gfc_convert_mpz_to_signed (mpz_t x
, int bitsize
)
188 /* Confirm that no bits above the unsigned range are set if we are
189 doing range checking. */
190 if (flag_range_check
!= 0)
191 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
193 if (mpz_tstbit (x
, bitsize
- 1) == 1)
195 mpz_init_set_ui (mask
, 1);
196 mpz_mul_2exp (mask
, mask
, bitsize
);
197 mpz_sub_ui (mask
, mask
, 1);
199 /* We negate the number by hand, zeroing the high bits, that is
200 make it the corresponding positive number, and then have it
201 negated by GMP, giving the correct representation of the
204 mpz_add_ui (x
, x
, 1);
205 mpz_and (x
, x
, mask
);
214 /* In-place convert BOZ to REAL of the specified kind. */
217 convert_boz (gfc_expr
*x
, int kind
)
219 if (x
&& x
->ts
.type
== BT_INTEGER
&& x
->is_boz
)
226 if (!gfc_convert_boz (x
, &ts
))
227 return &gfc_bad_expr
;
234 /* Test that the expression is a constant array, simplifying if
235 we are dealing with a parameter array. */
238 is_constant_array_expr (gfc_expr
*e
)
245 if (e
->expr_type
== EXPR_VARIABLE
&& e
->rank
> 0
246 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
247 gfc_simplify_expr (e
, 1);
249 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
252 for (c
= gfc_constructor_first (e
->value
.constructor
);
253 c
; c
= gfc_constructor_next (c
))
254 if (c
->expr
->expr_type
!= EXPR_CONSTANT
255 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
261 /* Test for a size zero array. */
263 gfc_is_size_zero_array (gfc_expr
*array
)
266 if (array
->rank
== 0)
269 if (array
->expr_type
== EXPR_VARIABLE
&& array
->rank
> 0
270 && array
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
271 && array
->shape
!= NULL
)
273 for (int i
= 0; i
< array
->rank
; i
++)
274 if (mpz_cmp_si (array
->shape
[i
], 0) <= 0)
280 if (array
->expr_type
== EXPR_ARRAY
)
281 return array
->value
.constructor
== NULL
;
287 /* Initialize a transformational result expression with a given value. */
290 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
292 if (e
&& e
->expr_type
== EXPR_ARRAY
)
294 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
297 init_result_expr (ctor
->expr
, init
, array
);
298 ctor
= gfc_constructor_next (ctor
);
301 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
303 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
304 HOST_WIDE_INT length
;
310 e
->value
.logical
= (init
? 1 : 0);
315 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
316 else if (init
== INT_MAX
)
317 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
319 mpz_set_si (e
->value
.integer
, init
);
325 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
326 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
328 else if (init
== INT_MAX
)
329 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
331 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
335 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
341 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
342 gfc_extract_hwi (len
, &length
);
343 string
= gfc_get_wide_string (length
+ 1);
344 gfc_wide_memset (string
, 0, length
);
346 else if (init
== INT_MAX
)
348 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
349 gfc_extract_hwi (len
, &length
);
350 string
= gfc_get_wide_string (length
+ 1);
351 gfc_wide_memset (string
, 255, length
);
356 string
= gfc_get_wide_string (1);
359 string
[length
] = '\0';
360 e
->value
.character
.length
= length
;
361 e
->value
.character
.string
= string
;
373 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
374 if conj_a is true, the matrix_a is complex conjugated. */
377 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
378 gfc_expr
*matrix_b
, int stride_b
, int offset_b
,
381 gfc_expr
*result
, *a
, *b
, *c
;
383 /* Set result to an INTEGER(1) 0 for numeric types and .false. for
384 LOGICAL. Mixed-mode math in the loop will promote result to the
385 correct type and kind. */
386 if (matrix_a
->ts
.type
== BT_LOGICAL
)
387 result
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, false);
389 result
= gfc_get_int_expr (1, NULL
, 0);
390 result
->where
= matrix_a
->where
;
392 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
393 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
396 /* Copying of expressions is required as operands are free'd
397 by the gfc_arith routines. */
398 switch (result
->ts
.type
)
401 result
= gfc_or (result
,
402 gfc_and (gfc_copy_expr (a
),
409 if (conj_a
&& a
->ts
.type
== BT_COMPLEX
)
410 c
= gfc_simplify_conjg (a
);
412 c
= gfc_copy_expr (a
);
413 result
= gfc_add (result
, gfc_multiply (c
, gfc_copy_expr (b
)));
420 offset_a
+= stride_a
;
421 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
423 offset_b
+= stride_b
;
424 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
431 /* Build a result expression for transformational intrinsics,
435 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
436 int kind
, locus
* where
)
441 if (!dim
|| array
->rank
== 1)
442 return gfc_get_constant_expr (type
, kind
, where
);
444 result
= gfc_get_array_expr (type
, kind
, where
);
445 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
446 result
->rank
= array
->rank
- 1;
448 /* gfc_array_size() would count the number of elements in the constructor,
449 we have not built those yet. */
451 for (i
= 0; i
< result
->rank
; ++i
)
452 nelem
*= mpz_get_ui (result
->shape
[i
]);
454 for (i
= 0; i
< nelem
; ++i
)
456 gfc_constructor_append_expr (&result
->value
.constructor
,
457 gfc_get_constant_expr (type
, kind
, where
),
465 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
467 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
468 of COUNT intrinsic is .TRUE..
470 Interface and implementation mimics arith functions as
471 gfc_add, gfc_multiply, etc. */
474 gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
478 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
479 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
480 gcc_assert (op2
->value
.logical
);
482 result
= gfc_copy_expr (op1
);
483 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
491 /* Transforms an ARRAY with operation OP, according to MASK, to a
492 scalar RESULT. E.g. called if
494 REAL, PARAMETER :: array(n, m) = ...
495 REAL, PARAMETER :: s = SUM(array)
497 where OP == gfc_add(). */
500 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
501 transformational_op op
)
504 gfc_constructor
*array_ctor
, *mask_ctor
;
506 /* Shortcut for constant .FALSE. MASK. */
508 && mask
->expr_type
== EXPR_CONSTANT
509 && !mask
->value
.logical
)
512 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
514 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
515 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
519 a
= array_ctor
->expr
;
520 array_ctor
= gfc_constructor_next (array_ctor
);
522 /* A constant MASK equals .TRUE. here and can be ignored. */
526 mask_ctor
= gfc_constructor_next (mask_ctor
);
527 if (!m
->value
.logical
)
531 result
= op (result
, gfc_copy_expr (a
));
539 /* Transforms an ARRAY with operation OP, according to MASK, to an
540 array RESULT. E.g. called if
542 REAL, PARAMETER :: array(n, m) = ...
543 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
545 where OP == gfc_multiply().
546 The result might be post processed using post_op. */
549 simplify_transformation_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*dim
,
550 gfc_expr
*mask
, transformational_op op
,
551 transformational_op post_op
)
554 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
555 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
556 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
558 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
559 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
560 tmpstride
[GFC_MAX_DIMENSIONS
];
562 /* Shortcut for constant .FALSE. MASK. */
564 && mask
->expr_type
== EXPR_CONSTANT
565 && !mask
->value
.logical
)
568 /* Build an indexed table for array element expressions to minimize
569 linked-list traversal. Masked elements are set to NULL. */
570 gfc_array_size (array
, &size
);
571 arraysize
= mpz_get_ui (size
);
574 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
576 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
578 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
579 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
581 for (i
= 0; i
< arraysize
; ++i
)
583 arrayvec
[i
] = array_ctor
->expr
;
584 array_ctor
= gfc_constructor_next (array_ctor
);
588 if (!mask_ctor
->expr
->value
.logical
)
591 mask_ctor
= gfc_constructor_next (mask_ctor
);
595 /* Same for the result expression. */
596 gfc_array_size (result
, &size
);
597 resultsize
= mpz_get_ui (size
);
600 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
601 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
602 for (i
= 0; i
< resultsize
; ++i
)
604 resultvec
[i
] = result_ctor
->expr
;
605 result_ctor
= gfc_constructor_next (result_ctor
);
608 gfc_extract_int (dim
, &dim_index
);
609 dim_index
-= 1; /* zero-base index */
613 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
616 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
619 dim_extent
= mpz_get_si (array
->shape
[i
]);
620 dim_stride
= tmpstride
[i
];
624 extent
[n
] = mpz_get_si (array
->shape
[i
]);
625 sstride
[n
] = tmpstride
[i
];
626 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
635 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
637 *dest
= op (*dest
, gfc_copy_expr (*src
));
644 while (!done
&& count
[n
] == extent
[n
])
647 base
-= sstride
[n
] * extent
[n
];
648 dest
-= dstride
[n
] * extent
[n
];
651 if (n
< result
->rank
)
653 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
654 times, we'd warn for the last iteration, because the
655 array index will have already been incremented to the
656 array sizes, and we can't tell that this must make
657 the test against result->rank false, because ranks
658 must not exceed GFC_MAX_DIMENSIONS. */
659 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
670 /* Place updated expression in result constructor. */
671 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
672 for (i
= 0; i
< resultsize
; ++i
)
675 result_ctor
->expr
= post_op (result_ctor
->expr
, resultvec
[i
]);
677 result_ctor
->expr
= resultvec
[i
];
678 result_ctor
= gfc_constructor_next (result_ctor
);
688 simplify_transformation (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
689 int init_val
, transformational_op op
)
693 if (!is_constant_array_expr (array
)
694 || !gfc_is_constant_expr (dim
))
698 && !is_constant_array_expr (mask
)
699 && mask
->expr_type
!= EXPR_CONSTANT
)
702 result
= transformational_result (array
, dim
, array
->ts
.type
,
703 array
->ts
.kind
, &array
->where
);
704 init_result_expr (result
, init_val
, array
);
706 return !dim
|| array
->rank
== 1 ?
707 simplify_transformation_to_scalar (result
, array
, mask
, op
) :
708 simplify_transformation_to_array (result
, array
, dim
, mask
, op
, NULL
);
712 /********************** Simplification functions *****************************/
715 gfc_simplify_abs (gfc_expr
*e
)
719 if (e
->expr_type
!= EXPR_CONSTANT
)
725 result
= gfc_get_constant_expr (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
726 mpz_abs (result
->value
.integer
, e
->value
.integer
);
727 return range_check (result
, "IABS");
730 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
731 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
732 return range_check (result
, "ABS");
735 gfc_set_model_kind (e
->ts
.kind
);
736 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
737 mpc_abs (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
738 return range_check (result
, "CABS");
741 gfc_internal_error ("gfc_simplify_abs(): Bad type");
747 simplify_achar_char (gfc_expr
*e
, gfc_expr
*k
, const char *name
, bool ascii
)
751 bool too_large
= false;
753 if (e
->expr_type
!= EXPR_CONSTANT
)
756 kind
= get_kind (BT_CHARACTER
, k
, name
, gfc_default_character_kind
);
758 return &gfc_bad_expr
;
760 if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
762 gfc_error ("Argument of %s function at %L is negative", name
,
764 return &gfc_bad_expr
;
767 if (ascii
&& warn_surprising
&& mpz_cmp_si (e
->value
.integer
, 127) > 0)
768 gfc_warning (OPT_Wsurprising
,
769 "Argument of %s function at %L outside of range [0,127]",
772 if (kind
== 1 && mpz_cmp_si (e
->value
.integer
, 255) > 0)
777 mpz_init_set_ui (t
, 2);
778 mpz_pow_ui (t
, t
, 32);
779 mpz_sub_ui (t
, t
, 1);
780 if (mpz_cmp (e
->value
.integer
, t
) > 0)
787 gfc_error ("Argument of %s function at %L is too large for the "
788 "collating sequence of kind %d", name
, &e
->where
, kind
);
789 return &gfc_bad_expr
;
792 result
= gfc_get_character_expr (kind
, &e
->where
, NULL
, 1);
793 result
->value
.character
.string
[0] = mpz_get_ui (e
->value
.integer
);
800 /* We use the processor's collating sequence, because all
801 systems that gfortran currently works on are ASCII. */
804 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
806 return simplify_achar_char (e
, k
, "ACHAR", true);
811 gfc_simplify_acos (gfc_expr
*x
)
815 if (x
->expr_type
!= EXPR_CONSTANT
)
821 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
822 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
824 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
826 return &gfc_bad_expr
;
828 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
829 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
833 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
834 mpc_acos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
838 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
841 return range_check (result
, "ACOS");
845 gfc_simplify_acosh (gfc_expr
*x
)
849 if (x
->expr_type
!= EXPR_CONSTANT
)
855 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
857 gfc_error ("Argument of ACOSH at %L must not be less than 1",
859 return &gfc_bad_expr
;
862 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
863 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
867 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
868 mpc_acosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
872 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
875 return range_check (result
, "ACOSH");
879 gfc_simplify_adjustl (gfc_expr
*e
)
885 if (e
->expr_type
!= EXPR_CONSTANT
)
888 len
= e
->value
.character
.length
;
890 for (count
= 0, i
= 0; i
< len
; ++i
)
892 ch
= e
->value
.character
.string
[i
];
898 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
899 for (i
= 0; i
< len
- count
; ++i
)
900 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
907 gfc_simplify_adjustr (gfc_expr
*e
)
913 if (e
->expr_type
!= EXPR_CONSTANT
)
916 len
= e
->value
.character
.length
;
918 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
920 ch
= e
->value
.character
.string
[i
];
926 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
927 for (i
= 0; i
< count
; ++i
)
928 result
->value
.character
.string
[i
] = ' ';
930 for (i
= count
; i
< len
; ++i
)
931 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
938 gfc_simplify_aimag (gfc_expr
*e
)
942 if (e
->expr_type
!= EXPR_CONSTANT
)
945 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
946 mpfr_set (result
->value
.real
, mpc_imagref (e
->value
.complex), GFC_RND_MODE
);
948 return range_check (result
, "AIMAG");
953 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
955 gfc_expr
*rtrunc
, *result
;
958 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
960 return &gfc_bad_expr
;
962 if (e
->expr_type
!= EXPR_CONSTANT
)
965 rtrunc
= gfc_copy_expr (e
);
966 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
968 result
= gfc_real2real (rtrunc
, kind
);
970 gfc_free_expr (rtrunc
);
972 return range_check (result
, "AINT");
977 gfc_simplify_all (gfc_expr
*mask
, gfc_expr
*dim
)
979 if (gfc_is_size_zero_array (mask
))
980 return gfc_get_logical_expr (mask
->ts
.kind
, &mask
->where
, true);
982 return simplify_transformation (mask
, dim
, NULL
, true, gfc_and
);
987 gfc_simplify_dint (gfc_expr
*e
)
989 gfc_expr
*rtrunc
, *result
;
991 if (e
->expr_type
!= EXPR_CONSTANT
)
994 rtrunc
= gfc_copy_expr (e
);
995 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
997 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
999 gfc_free_expr (rtrunc
);
1001 return range_check (result
, "DINT");
1006 gfc_simplify_dreal (gfc_expr
*e
)
1008 gfc_expr
*result
= NULL
;
1010 if (e
->expr_type
!= EXPR_CONSTANT
)
1013 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
1014 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
1016 return range_check (result
, "DREAL");
1021 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
1026 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
1028 return &gfc_bad_expr
;
1030 if (e
->expr_type
!= EXPR_CONSTANT
)
1033 result
= gfc_get_constant_expr (e
->ts
.type
, kind
, &e
->where
);
1034 mpfr_round (result
->value
.real
, e
->value
.real
);
1036 return range_check (result
, "ANINT");
1041 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
1046 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1049 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1054 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
1055 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1056 return range_check (result
, "AND");
1059 return gfc_get_logical_expr (kind
, &x
->where
,
1060 x
->value
.logical
&& y
->value
.logical
);
1069 gfc_simplify_any (gfc_expr
*mask
, gfc_expr
*dim
)
1071 if (gfc_is_size_zero_array (mask
))
1072 return gfc_get_logical_expr (mask
->ts
.kind
, &mask
->where
, false);
1074 return simplify_transformation (mask
, dim
, NULL
, false, gfc_or
);
1079 gfc_simplify_dnint (gfc_expr
*e
)
1083 if (e
->expr_type
!= EXPR_CONSTANT
)
1086 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &e
->where
);
1087 mpfr_round (result
->value
.real
, e
->value
.real
);
1089 return range_check (result
, "DNINT");
1094 gfc_simplify_asin (gfc_expr
*x
)
1098 if (x
->expr_type
!= EXPR_CONSTANT
)
1104 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1105 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1107 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1109 return &gfc_bad_expr
;
1111 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1112 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1116 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1117 mpc_asin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1121 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1124 return range_check (result
, "ASIN");
1129 gfc_simplify_asinh (gfc_expr
*x
)
1133 if (x
->expr_type
!= EXPR_CONSTANT
)
1136 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1141 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1145 mpc_asinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1149 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1152 return range_check (result
, "ASINH");
1157 gfc_simplify_atan (gfc_expr
*x
)
1161 if (x
->expr_type
!= EXPR_CONSTANT
)
1164 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1169 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1173 mpc_atan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1177 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1180 return range_check (result
, "ATAN");
1185 gfc_simplify_atanh (gfc_expr
*x
)
1189 if (x
->expr_type
!= EXPR_CONSTANT
)
1195 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
1196 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
1198 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1200 return &gfc_bad_expr
;
1202 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1203 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1207 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1208 mpc_atanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1212 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1215 return range_check (result
, "ATANH");
1220 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1224 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1227 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1229 gfc_error ("If first argument of ATAN2 %L is zero, then the "
1230 "second argument must not be zero", &x
->where
);
1231 return &gfc_bad_expr
;
1234 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1235 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1237 return range_check (result
, "ATAN2");
1242 gfc_simplify_bessel_j0 (gfc_expr
*x
)
1246 if (x
->expr_type
!= EXPR_CONSTANT
)
1249 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1250 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1252 return range_check (result
, "BESSEL_J0");
1257 gfc_simplify_bessel_j1 (gfc_expr
*x
)
1261 if (x
->expr_type
!= EXPR_CONSTANT
)
1264 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1265 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1267 return range_check (result
, "BESSEL_J1");
1272 gfc_simplify_bessel_jn (gfc_expr
*order
, gfc_expr
*x
)
1277 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1280 n
= mpz_get_si (order
->value
.integer
);
1281 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1282 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1284 return range_check (result
, "BESSEL_JN");
1288 /* Simplify transformational form of JN and YN. */
1291 gfc_simplify_bessel_n2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
,
1298 mpfr_t x2rev
, last1
, last2
;
1300 if (x
->expr_type
!= EXPR_CONSTANT
|| order1
->expr_type
!= EXPR_CONSTANT
1301 || order2
->expr_type
!= EXPR_CONSTANT
)
1304 n1
= mpz_get_si (order1
->value
.integer
);
1305 n2
= mpz_get_si (order2
->value
.integer
);
1306 result
= gfc_get_array_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1308 result
->shape
= gfc_get_shape (1);
1309 mpz_init_set_ui (result
->shape
[0], MAX (n2
-n1
+1, 0));
1314 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1315 YN(N, 0.0) = -Inf. */
1317 if (mpfr_cmp_ui (x
->value
.real
, 0.0) == 0)
1319 if (!jn
&& flag_range_check
)
1321 gfc_error ("Result of BESSEL_YN is -INF at %L", &result
->where
);
1322 gfc_free_expr (result
);
1323 return &gfc_bad_expr
;
1328 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1329 mpfr_set_ui (e
->value
.real
, 1, GFC_RND_MODE
);
1330 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1335 for (i
= n1
; i
<= n2
; i
++)
1337 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1339 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
1341 mpfr_set_inf (e
->value
.real
, -1);
1342 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1349 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1350 are stable for downward recursion and Neumann functions are stable
1351 for upward recursion. It is
1353 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1354 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1355 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1357 gfc_set_model_kind (x
->ts
.kind
);
1359 /* Get first recursion anchor. */
1363 mpfr_jn (last1
, n2
, x
->value
.real
, GFC_RND_MODE
);
1365 mpfr_yn (last1
, n1
, x
->value
.real
, GFC_RND_MODE
);
1367 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1368 mpfr_set (e
->value
.real
, last1
, GFC_RND_MODE
);
1369 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1373 gfc_free_expr (result
);
1374 return &gfc_bad_expr
;
1376 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1384 /* Get second recursion anchor. */
1388 mpfr_jn (last2
, n2
-1, x
->value
.real
, GFC_RND_MODE
);
1390 mpfr_yn (last2
, n1
+1, x
->value
.real
, GFC_RND_MODE
);
1392 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1393 mpfr_set (e
->value
.real
, last2
, GFC_RND_MODE
);
1394 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1399 gfc_free_expr (result
);
1400 return &gfc_bad_expr
;
1403 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
, -2);
1405 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1414 /* Start actual recursion. */
1417 mpfr_ui_div (x2rev
, 2, x
->value
.real
, GFC_RND_MODE
);
1419 for (i
= 2; i
<= n2
-n1
; i
++)
1421 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1423 /* Special case: For YN, if the previous N gave -INF, set
1424 also N+1 to -INF. */
1425 if (!jn
&& !flag_range_check
&& mpfr_inf_p (last2
))
1427 mpfr_set_inf (e
->value
.real
, -1);
1428 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1433 mpfr_mul_si (e
->value
.real
, x2rev
, jn
? (n2
-i
+1) : (n1
+i
-1),
1435 mpfr_mul (e
->value
.real
, e
->value
.real
, last2
, GFC_RND_MODE
);
1436 mpfr_sub (e
->value
.real
, e
->value
.real
, last1
, GFC_RND_MODE
);
1438 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1440 /* Range_check frees "e" in that case. */
1446 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
,
1449 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1451 mpfr_set (last1
, last2
, GFC_RND_MODE
);
1452 mpfr_set (last2
, e
->value
.real
, GFC_RND_MODE
);
1465 gfc_free_expr (result
);
1466 return &gfc_bad_expr
;
1471 gfc_simplify_bessel_jn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1473 return gfc_simplify_bessel_n2 (order1
, order2
, x
, true);
1478 gfc_simplify_bessel_y0 (gfc_expr
*x
)
1482 if (x
->expr_type
!= EXPR_CONSTANT
)
1485 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1486 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1488 return range_check (result
, "BESSEL_Y0");
1493 gfc_simplify_bessel_y1 (gfc_expr
*x
)
1497 if (x
->expr_type
!= EXPR_CONSTANT
)
1500 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1501 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1503 return range_check (result
, "BESSEL_Y1");
1508 gfc_simplify_bessel_yn (gfc_expr
*order
, gfc_expr
*x
)
1513 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1516 n
= mpz_get_si (order
->value
.integer
);
1517 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1518 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1520 return range_check (result
, "BESSEL_YN");
1525 gfc_simplify_bessel_yn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1527 return gfc_simplify_bessel_n2 (order1
, order2
, x
, false);
1532 gfc_simplify_bit_size (gfc_expr
*e
)
1534 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1535 return gfc_get_int_expr (e
->ts
.kind
, &e
->where
,
1536 gfc_integer_kinds
[i
].bit_size
);
1541 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
1545 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
1548 if (gfc_extract_int (bit
, &b
) || b
< 0)
1549 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
, false);
1551 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
,
1552 mpz_tstbit (e
->value
.integer
, b
));
1557 compare_bitwise (gfc_expr
*i
, gfc_expr
*j
)
1562 gcc_assert (i
->ts
.type
== BT_INTEGER
);
1563 gcc_assert (j
->ts
.type
== BT_INTEGER
);
1565 mpz_init_set (x
, i
->value
.integer
);
1566 k
= gfc_validate_kind (i
->ts
.type
, i
->ts
.kind
, false);
1567 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
1569 mpz_init_set (y
, j
->value
.integer
);
1570 k
= gfc_validate_kind (j
->ts
.type
, j
->ts
.kind
, false);
1571 convert_mpz_to_unsigned (y
, gfc_integer_kinds
[k
].bit_size
);
1573 res
= mpz_cmp (x
, y
);
1581 gfc_simplify_bge (gfc_expr
*i
, gfc_expr
*j
)
1583 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1586 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1587 compare_bitwise (i
, j
) >= 0);
1592 gfc_simplify_bgt (gfc_expr
*i
, gfc_expr
*j
)
1594 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1597 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1598 compare_bitwise (i
, j
) > 0);
1603 gfc_simplify_ble (gfc_expr
*i
, gfc_expr
*j
)
1605 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1608 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1609 compare_bitwise (i
, j
) <= 0);
1614 gfc_simplify_blt (gfc_expr
*i
, gfc_expr
*j
)
1616 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1619 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1620 compare_bitwise (i
, j
) < 0);
1625 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
1627 gfc_expr
*ceil
, *result
;
1630 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
1632 return &gfc_bad_expr
;
1634 if (e
->expr_type
!= EXPR_CONSTANT
)
1637 ceil
= gfc_copy_expr (e
);
1638 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
1640 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
1641 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
, &e
->where
);
1643 gfc_free_expr (ceil
);
1645 return range_check (result
, "CEILING");
1650 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
1652 return simplify_achar_char (e
, k
, "CHAR", false);
1656 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1659 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
1663 if (convert_boz (x
, kind
) == &gfc_bad_expr
)
1664 return &gfc_bad_expr
;
1666 if (convert_boz (y
, kind
) == &gfc_bad_expr
)
1667 return &gfc_bad_expr
;
1669 if (x
->expr_type
!= EXPR_CONSTANT
1670 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1673 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &x
->where
);
1678 mpc_set_z (result
->value
.complex, x
->value
.integer
, GFC_MPC_RND_MODE
);
1682 mpc_set_fr (result
->value
.complex, x
->value
.real
, GFC_RND_MODE
);
1686 mpc_set (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1690 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1694 return range_check (result
, name
);
1699 mpfr_set_z (mpc_imagref (result
->value
.complex),
1700 y
->value
.integer
, GFC_RND_MODE
);
1704 mpfr_set (mpc_imagref (result
->value
.complex),
1705 y
->value
.real
, GFC_RND_MODE
);
1709 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1712 return range_check (result
, name
);
1717 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
1721 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_complex_kind
);
1723 return &gfc_bad_expr
;
1725 return simplify_cmplx ("CMPLX", x
, y
, kind
);
1730 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
1734 if (x
->ts
.type
== BT_INTEGER
&& y
->ts
.type
== BT_INTEGER
)
1735 kind
= gfc_default_complex_kind
;
1736 else if (x
->ts
.type
== BT_REAL
|| y
->ts
.type
== BT_INTEGER
)
1738 else if (x
->ts
.type
== BT_INTEGER
|| y
->ts
.type
== BT_REAL
)
1740 else if (x
->ts
.type
== BT_REAL
&& y
->ts
.type
== BT_REAL
)
1741 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
1745 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1750 gfc_simplify_conjg (gfc_expr
*e
)
1754 if (e
->expr_type
!= EXPR_CONSTANT
)
1757 result
= gfc_copy_expr (e
);
1758 mpc_conj (result
->value
.complex, result
->value
.complex, GFC_MPC_RND_MODE
);
1760 return range_check (result
, "CONJG");
1763 /* Return the simplification of the constant expression in icall, or NULL
1764 if the expression is not constant. */
1767 simplify_trig_call (gfc_expr
*icall
)
1769 gfc_isym_id func
= icall
->value
.function
.isym
->id
;
1770 gfc_expr
*x
= icall
->value
.function
.actual
->expr
;
1772 /* The actual simplifiers will return NULL for non-constant x. */
1776 return gfc_simplify_acos (x
);
1778 return gfc_simplify_asin (x
);
1780 return gfc_simplify_atan (x
);
1782 return gfc_simplify_cos (x
);
1783 case GFC_ISYM_COTAN
:
1784 return gfc_simplify_cotan (x
);
1786 return gfc_simplify_sin (x
);
1788 return gfc_simplify_tan (x
);
1790 gfc_internal_error ("in simplify_trig_call(): Bad intrinsic");
1794 /* Convert a floating-point number from radians to degrees. */
1797 degrees_f (mpfr_t x
, mp_rnd_t rnd_mode
)
1802 /* Set x = x % 2pi to avoid offsets with large angles. */
1803 mpfr_const_pi (tmp
, rnd_mode
);
1804 mpfr_mul_ui (tmp
, tmp
, 2, rnd_mode
);
1805 mpfr_fmod (tmp
, x
, tmp
, rnd_mode
);
1807 /* Set x = x * 180. */
1808 mpfr_mul_ui (x
, x
, 180, rnd_mode
);
1810 /* Set x = x / pi. */
1811 mpfr_const_pi (tmp
, rnd_mode
);
1812 mpfr_div (x
, x
, tmp
, rnd_mode
);
1817 /* Convert a floating-point number from degrees to radians. */
1820 radians_f (mpfr_t x
, mp_rnd_t rnd_mode
)
1825 /* Set x = x % 360 to avoid offsets with large angles. */
1826 mpfr_set_ui (tmp
, 360, rnd_mode
);
1827 mpfr_fmod (tmp
, x
, tmp
, rnd_mode
);
1829 /* Set x = x * pi. */
1830 mpfr_const_pi (tmp
, rnd_mode
);
1831 mpfr_mul (x
, x
, tmp
, rnd_mode
);
1833 /* Set x = x / 180. */
1834 mpfr_div_ui (x
, x
, 180, rnd_mode
);
1840 /* Convert argument to radians before calling a trig function. */
1843 gfc_simplify_trigd (gfc_expr
*icall
)
1847 arg
= icall
->value
.function
.actual
->expr
;
1849 if (arg
->ts
.type
!= BT_REAL
)
1850 gfc_internal_error ("in gfc_simplify_trigd(): Bad type");
1852 if (arg
->expr_type
== EXPR_CONSTANT
)
1853 /* Convert constant to radians before passing off to simplifier. */
1854 radians_f (arg
->value
.real
, GFC_RND_MODE
);
1856 /* Let the usual simplifier take over - we just simplified the arg. */
1857 return simplify_trig_call (icall
);
1860 /* Convert result of an inverse trig function to degrees. */
1863 gfc_simplify_atrigd (gfc_expr
*icall
)
1867 if (icall
->value
.function
.actual
->expr
->ts
.type
!= BT_REAL
)
1868 gfc_internal_error ("in gfc_simplify_atrigd(): Bad type");
1870 /* See if another simplifier has work to do first. */
1871 result
= simplify_trig_call (icall
);
1873 if (result
&& result
->expr_type
== EXPR_CONSTANT
)
1875 /* Convert constant to degrees after passing off to actual simplifier. */
1876 degrees_f (result
->value
.real
, GFC_RND_MODE
);
1880 /* Let gfc_resolve_atrigd take care of the non-constant case. */
1884 /* Convert the result of atan2 to degrees. */
1887 gfc_simplify_atan2d (gfc_expr
*y
, gfc_expr
*x
)
1891 if (x
->ts
.type
!= BT_REAL
|| y
->ts
.type
!= BT_REAL
)
1892 gfc_internal_error ("in gfc_simplify_atan2d(): Bad type");
1894 if (x
->expr_type
== EXPR_CONSTANT
&& y
->expr_type
== EXPR_CONSTANT
)
1896 result
= gfc_simplify_atan2 (y
, x
);
1899 degrees_f (result
->value
.real
, GFC_RND_MODE
);
1904 /* Let gfc_resolve_atan2d take care of the non-constant case. */
1909 gfc_simplify_cos (gfc_expr
*x
)
1913 if (x
->expr_type
!= EXPR_CONSTANT
)
1916 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1921 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1925 gfc_set_model_kind (x
->ts
.kind
);
1926 mpc_cos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1930 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1933 return range_check (result
, "COS");
1938 gfc_simplify_cosh (gfc_expr
*x
)
1942 if (x
->expr_type
!= EXPR_CONSTANT
)
1945 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1950 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1954 mpc_cosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1961 return range_check (result
, "COSH");
1966 gfc_simplify_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1970 if (gfc_is_size_zero_array (mask
))
1973 k
= kind
? mpz_get_si (kind
->value
.integer
) : gfc_default_integer_kind
;
1974 return gfc_get_int_expr (k
, NULL
, 0);
1977 if (!is_constant_array_expr (mask
)
1978 || !gfc_is_constant_expr (dim
)
1979 || !gfc_is_constant_expr (kind
))
1982 result
= transformational_result (mask
, dim
,
1984 get_kind (BT_INTEGER
, kind
, "COUNT",
1985 gfc_default_integer_kind
),
1988 init_result_expr (result
, 0, NULL
);
1990 /* Passing MASK twice, once as data array, once as mask.
1991 Whenever gfc_count is called, '1' is added to the result. */
1992 return !dim
|| mask
->rank
== 1 ?
1993 simplify_transformation_to_scalar (result
, mask
, mask
, gfc_count
) :
1994 simplify_transformation_to_array (result
, mask
, dim
, mask
, gfc_count
, NULL
);
1997 /* Simplification routine for cshift. This works by copying the array
1998 expressions into a one-dimensional array, shuffling the values into another
1999 one-dimensional array and creating the new array expression from this. The
2000 shuffling part is basically taken from the library routine. */
2003 gfc_simplify_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
2007 gfc_expr
**arrayvec
, **resultvec
;
2008 gfc_expr
**rptr
, **sptr
;
2010 size_t arraysize
, shiftsize
, i
;
2011 gfc_constructor
*array_ctor
, *shift_ctor
;
2012 ssize_t
*shiftvec
, *hptr
;
2013 ssize_t shift_val
, len
;
2014 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
2015 hs_ex
[GFC_MAX_DIMENSIONS
],
2016 hstride
[GFC_MAX_DIMENSIONS
], sstride
[GFC_MAX_DIMENSIONS
],
2017 a_extent
[GFC_MAX_DIMENSIONS
], a_stride
[GFC_MAX_DIMENSIONS
],
2018 h_extent
[GFC_MAX_DIMENSIONS
],
2019 ss_ex
[GFC_MAX_DIMENSIONS
];
2023 gfc_expr
**src
, **dest
;
2025 if (!is_constant_array_expr (array
))
2028 if (shift
->rank
> 0)
2029 gfc_simplify_expr (shift
, 1);
2031 if (!gfc_is_constant_expr (shift
))
2034 /* Make dim zero-based. */
2037 if (!gfc_is_constant_expr (dim
))
2039 which
= mpz_get_si (dim
->value
.integer
) - 1;
2044 gfc_array_size (array
, &size
);
2045 arraysize
= mpz_get_ui (size
);
2048 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
2049 result
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
2050 result
->rank
= array
->rank
;
2051 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
2056 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2057 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
2058 for (i
= 0; i
< arraysize
; i
++)
2060 arrayvec
[i
] = array_ctor
->expr
;
2061 array_ctor
= gfc_constructor_next (array_ctor
);
2064 resultvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2069 for (d
=0; d
< array
->rank
; d
++)
2071 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2072 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2075 if (shift
->rank
> 0)
2077 gfc_array_size (shift
, &size
);
2078 shiftsize
= mpz_get_ui (size
);
2080 shiftvec
= XCNEWVEC (ssize_t
, shiftsize
);
2081 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2082 for (d
= 0; d
< shift
->rank
; d
++)
2084 h_extent
[d
] = mpz_get_si (shift
->shape
[d
]);
2085 hstride
[d
] = d
== 0 ? 1 : hstride
[d
-1] * h_extent
[d
-1];
2091 /* Shut up compiler */
2096 for (d
=0; d
< array
->rank
; d
++)
2100 rsoffset
= a_stride
[d
];
2106 extent
[n
] = a_extent
[d
];
2107 sstride
[n
] = a_stride
[d
];
2108 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2110 hs_ex
[n
] = hstride
[n
] * extent
[n
];
2117 for (i
= 0; i
< shiftsize
; i
++)
2120 val
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2125 shift_ctor
= gfc_constructor_next (shift_ctor
);
2131 shift_val
= mpz_get_si (shift
->value
.integer
);
2132 shift_val
= shift_val
% len
;
2137 continue_loop
= true;
2143 while (continue_loop
)
2151 src
= &sptr
[sh
* rsoffset
];
2153 for (n
= 0; n
< len
- sh
; n
++)
2160 for ( n
= 0; n
< sh
; n
++)
2172 while (count
[n
] == extent
[n
])
2182 continue_loop
= false;
2196 for (i
= 0; i
< arraysize
; i
++)
2198 gfc_constructor_append_expr (&result
->value
.constructor
,
2199 gfc_copy_expr (resultvec
[i
]),
2207 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2209 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
2214 gfc_simplify_dble (gfc_expr
*e
)
2216 gfc_expr
*result
= NULL
;
2218 if (e
->expr_type
!= EXPR_CONSTANT
)
2221 if (convert_boz (e
, gfc_default_double_kind
) == &gfc_bad_expr
)
2222 return &gfc_bad_expr
;
2224 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
2225 if (result
== &gfc_bad_expr
)
2226 return &gfc_bad_expr
;
2228 return range_check (result
, "DBLE");
2233 gfc_simplify_digits (gfc_expr
*x
)
2237 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2242 digits
= gfc_integer_kinds
[i
].digits
;
2247 digits
= gfc_real_kinds
[i
].digits
;
2254 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
2259 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
2264 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2267 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2268 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
2273 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
2274 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2276 mpz_set_ui (result
->value
.integer
, 0);
2281 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
2282 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
2285 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2290 gfc_internal_error ("gfc_simplify_dim(): Bad type");
2293 return range_check (result
, "DIM");
2298 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2300 /* If vector_a is a zero-sized array, the result is 0 for INTEGER,
2301 REAL, and COMPLEX types and .false. for LOGICAL. */
2302 if (vector_a
->shape
&& mpz_get_si (vector_a
->shape
[0]) == 0)
2304 if (vector_a
->ts
.type
== BT_LOGICAL
)
2305 return gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, false);
2307 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2310 if (!is_constant_array_expr (vector_a
)
2311 || !is_constant_array_expr (vector_b
))
2314 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
2319 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
2321 gfc_expr
*a1
, *a2
, *result
;
2323 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2326 a1
= gfc_real2real (x
, gfc_default_double_kind
);
2327 a2
= gfc_real2real (y
, gfc_default_double_kind
);
2329 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
2330 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
2335 return range_check (result
, "DPROD");
2340 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
2344 int i
, k
, size
, shift
;
2346 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
2347 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
2350 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
2351 size
= gfc_integer_kinds
[k
].bit_size
;
2353 gfc_extract_int (shiftarg
, &shift
);
2355 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2357 shift
= size
- shift
;
2359 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
2360 mpz_set_ui (result
->value
.integer
, 0);
2362 for (i
= 0; i
< shift
; i
++)
2363 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
2364 mpz_setbit (result
->value
.integer
, i
);
2366 for (i
= 0; i
< size
- shift
; i
++)
2367 if (mpz_tstbit (arg1
->value
.integer
, i
))
2368 mpz_setbit (result
->value
.integer
, shift
+ i
);
2370 /* Convert to a signed value. */
2371 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
2378 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2380 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
2385 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2387 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
2392 gfc_simplify_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2399 gfc_expr
**arrayvec
, **resultvec
;
2400 gfc_expr
**rptr
, **sptr
;
2402 size_t arraysize
, i
;
2403 gfc_constructor
*array_ctor
, *shift_ctor
, *bnd_ctor
;
2404 ssize_t shift_val
, len
;
2405 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
2406 sstride
[GFC_MAX_DIMENSIONS
], a_extent
[GFC_MAX_DIMENSIONS
],
2407 a_stride
[GFC_MAX_DIMENSIONS
], ss_ex
[GFC_MAX_DIMENSIONS
];
2411 gfc_expr
**src
, **dest
;
2414 if (!is_constant_array_expr (array
))
2417 if (shift
->rank
> 0)
2418 gfc_simplify_expr (shift
, 1);
2420 if (!gfc_is_constant_expr (shift
))
2425 if (boundary
->rank
> 0)
2426 gfc_simplify_expr (boundary
, 1);
2428 if (!gfc_is_constant_expr (boundary
))
2434 if (!gfc_is_constant_expr (dim
))
2436 which
= mpz_get_si (dim
->value
.integer
) - 1;
2442 if (boundary
== NULL
)
2444 temp_boundary
= true;
2445 switch (array
->ts
.type
)
2449 bnd
= gfc_get_int_expr (array
->ts
.kind
, NULL
, 0);
2453 bnd
= gfc_get_logical_expr (array
->ts
.kind
, NULL
, 0);
2457 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2458 mpfr_set_ui (bnd
->value
.real
, 0, GFC_RND_MODE
);
2462 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2463 mpc_set_ui (bnd
->value
.complex, 0, GFC_RND_MODE
);
2467 s_len
= mpz_get_ui (array
->ts
.u
.cl
->length
->value
.integer
);
2468 bnd
= gfc_get_character_expr (array
->ts
.kind
, &gfc_current_locus
, NULL
, s_len
);
2478 temp_boundary
= false;
2482 gfc_array_size (array
, &size
);
2483 arraysize
= mpz_get_ui (size
);
2486 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
2487 result
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
2488 result
->rank
= array
->rank
;
2489 result
->ts
= array
->ts
;
2494 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2495 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
2496 for (i
= 0; i
< arraysize
; i
++)
2498 arrayvec
[i
] = array_ctor
->expr
;
2499 array_ctor
= gfc_constructor_next (array_ctor
);
2502 resultvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2507 for (d
=0; d
< array
->rank
; d
++)
2509 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2510 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2513 if (shift
->rank
> 0)
2515 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2521 shift_val
= mpz_get_si (shift
->value
.integer
);
2525 bnd_ctor
= gfc_constructor_first (bnd
->value
.constructor
);
2529 /* Shut up compiler */
2534 for (d
=0; d
< array
->rank
; d
++)
2538 rsoffset
= a_stride
[d
];
2544 extent
[n
] = a_extent
[d
];
2545 sstride
[n
] = a_stride
[d
];
2546 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2551 continue_loop
= true;
2556 while (continue_loop
)
2561 sh
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2565 if (( sh
>= 0 ? sh
: -sh
) > len
)
2571 delta
= (sh
>= 0) ? sh
: -sh
;
2575 src
= &sptr
[delta
* rsoffset
];
2581 dest
= &rptr
[delta
* rsoffset
];
2584 for (n
= 0; n
< len
- delta
; n
++)
2600 *dest
= gfc_copy_expr (bnd_ctor
->expr
);
2608 *dest
= gfc_copy_expr (bnd
);
2615 shift_ctor
= gfc_constructor_next (shift_ctor
);
2618 bnd_ctor
= gfc_constructor_next (bnd_ctor
);
2622 while (count
[n
] == extent
[n
])
2630 continue_loop
= false;
2642 for (i
= 0; i
< arraysize
; i
++)
2644 gfc_constructor_append_expr (&result
->value
.constructor
,
2645 gfc_copy_expr (resultvec
[i
]),
2651 gfc_free_expr (bnd
);
2657 gfc_simplify_erf (gfc_expr
*x
)
2661 if (x
->expr_type
!= EXPR_CONSTANT
)
2664 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2665 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2667 return range_check (result
, "ERF");
2672 gfc_simplify_erfc (gfc_expr
*x
)
2676 if (x
->expr_type
!= EXPR_CONSTANT
)
2679 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2680 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2682 return range_check (result
, "ERFC");
2686 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2688 #define MAX_ITER 200
2689 #define ARG_LIMIT 12
2691 /* Calculate ERFC_SCALED directly by its definition:
2693 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2695 using a large precision for intermediate results. This is used for all
2696 but large values of the argument. */
2698 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2703 prec
= mpfr_get_default_prec ();
2704 mpfr_set_default_prec (10 * prec
);
2709 mpfr_set (a
, arg
, GFC_RND_MODE
);
2710 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2711 mpfr_exp (b
, b
, GFC_RND_MODE
);
2712 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2713 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2715 mpfr_set (res
, a
, GFC_RND_MODE
);
2716 mpfr_set_default_prec (prec
);
2722 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2724 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2725 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2728 This is used for large values of the argument. Intermediate calculations
2729 are performed with twice the precision. We don't do a fixed number of
2730 iterations of the sum, but stop when it has converged to the required
2733 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2735 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2740 prec
= mpfr_get_default_prec ();
2741 mpfr_set_default_prec (2 * prec
);
2751 mpfr_init (sumtrunc
);
2752 mpfr_set_prec (oldsum
, prec
);
2753 mpfr_set_prec (sumtrunc
, prec
);
2755 mpfr_set (x
, arg
, GFC_RND_MODE
);
2756 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2757 mpz_set_ui (num
, 1);
2759 mpfr_set (u
, x
, GFC_RND_MODE
);
2760 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2761 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2762 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2764 for (i
= 1; i
< MAX_ITER
; i
++)
2766 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2768 mpz_mul_ui (num
, num
, 2 * i
- 1);
2771 mpfr_set (w
, u
, GFC_RND_MODE
);
2772 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2774 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2775 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2777 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2779 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2780 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2784 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2786 gcc_assert (i
< MAX_ITER
);
2788 /* Divide by x * sqrt(Pi). */
2789 mpfr_const_pi (u
, GFC_RND_MODE
);
2790 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2791 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2792 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2794 mpfr_set (res
, sum
, GFC_RND_MODE
);
2795 mpfr_set_default_prec (prec
);
2797 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2803 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2807 if (x
->expr_type
!= EXPR_CONSTANT
)
2810 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2811 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2812 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2814 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2816 return range_check (result
, "ERFC_SCALED");
2824 gfc_simplify_epsilon (gfc_expr
*e
)
2829 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2831 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2832 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2834 return range_check (result
, "EPSILON");
2839 gfc_simplify_exp (gfc_expr
*x
)
2843 if (x
->expr_type
!= EXPR_CONSTANT
)
2846 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2851 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2855 gfc_set_model_kind (x
->ts
.kind
);
2856 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2860 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2863 return range_check (result
, "EXP");
2868 gfc_simplify_exponent (gfc_expr
*x
)
2873 if (x
->expr_type
!= EXPR_CONSTANT
)
2876 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2879 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2880 if (mpfr_inf_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
2882 int i
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
2883 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2887 /* EXPONENT(+/- 0.0) = 0 */
2888 if (mpfr_zero_p (x
->value
.real
))
2890 mpz_set_ui (result
->value
.integer
, 0);
2894 gfc_set_model (x
->value
.real
);
2896 val
= (long int) mpfr_get_exp (x
->value
.real
);
2897 mpz_set_si (result
->value
.integer
, val
);
2899 return range_check (result
, "EXPONENT");
2904 gfc_simplify_failed_or_stopped_images (gfc_expr
*team ATTRIBUTE_UNUSED
,
2907 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2909 gfc_current_locus
= *gfc_current_intrinsic_where
;
2910 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2911 return &gfc_bad_expr
;
2914 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2919 gfc_extract_int (kind
, &actual_kind
);
2921 actual_kind
= gfc_default_integer_kind
;
2923 result
= gfc_get_array_expr (BT_INTEGER
, actual_kind
, &gfc_current_locus
);
2928 /* For fcoarray = lib no simplification is possible, because it is not known
2929 what images failed or are stopped at compile time. */
2935 gfc_simplify_get_team (gfc_expr
*level ATTRIBUTE_UNUSED
)
2937 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2939 gfc_current_locus
= *gfc_current_intrinsic_where
;
2940 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2941 return &gfc_bad_expr
;
2944 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2947 result
= gfc_get_array_expr (BT_INTEGER
, gfc_default_integer_kind
, &gfc_current_locus
);
2952 /* For fcoarray = lib no simplification is possible, because it is not known
2953 what images failed or are stopped at compile time. */
2959 gfc_simplify_float (gfc_expr
*a
)
2963 if (a
->expr_type
!= EXPR_CONSTANT
)
2968 if (convert_boz (a
, gfc_default_real_kind
) == &gfc_bad_expr
)
2969 return &gfc_bad_expr
;
2971 result
= gfc_copy_expr (a
);
2974 result
= gfc_int2real (a
, gfc_default_real_kind
);
2976 return range_check (result
, "FLOAT");
2981 is_last_ref_vtab (gfc_expr
*e
)
2984 gfc_component
*comp
= NULL
;
2986 if (e
->expr_type
!= EXPR_VARIABLE
)
2989 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2990 if (ref
->type
== REF_COMPONENT
)
2991 comp
= ref
->u
.c
.component
;
2993 if (!e
->ref
|| !comp
)
2994 return e
->symtree
->n
.sym
->attr
.vtab
;
2996 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
3004 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
3006 /* Avoid simplification of resolved symbols. */
3007 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
3010 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
3011 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3012 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3015 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
3018 /* Return .false. if the dynamic type can never be an extension. */
3019 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
3020 && !gfc_type_is_extension_of
3021 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
3022 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
3023 && !gfc_type_is_extension_of
3024 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
3025 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
3026 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
3027 && !gfc_type_is_extension_of
3028 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
3030 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3031 && !gfc_type_is_extension_of
3032 (mold
->ts
.u
.derived
,
3033 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
3034 && !gfc_type_is_extension_of
3035 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
3036 mold
->ts
.u
.derived
)))
3037 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3039 /* Return .true. if the dynamic type is guaranteed to be an extension. */
3040 if (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3041 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3042 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
3043 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
3050 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3052 /* Avoid simplification of resolved symbols. */
3053 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
3056 /* Return .false. if the dynamic type can never be the
3058 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
3059 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
3060 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
3061 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
3062 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3064 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
3067 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3068 gfc_compare_derived_types (a
->ts
.u
.derived
,
3074 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
3080 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
3082 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3084 if (e
->expr_type
!= EXPR_CONSTANT
)
3087 mpfr_init2 (floor
, mpfr_get_prec (e
->value
.real
));
3088 mpfr_floor (floor
, e
->value
.real
);
3090 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
3091 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
3095 return range_check (result
, "FLOOR");
3100 gfc_simplify_fraction (gfc_expr
*x
)
3104 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
3105 mpfr_t absv
, exp
, pow2
;
3110 if (x
->expr_type
!= EXPR_CONSTANT
)
3113 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
3115 /* FRACTION(inf) = NaN. */
3116 if (mpfr_inf_p (x
->value
.real
))
3118 mpfr_set_nan (result
->value
.real
);
3122 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
3124 /* MPFR versions before 3.1.0 do not include mpfr_frexp.
3125 TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
3127 if (mpfr_sgn (x
->value
.real
) == 0)
3129 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3133 gfc_set_model_kind (x
->ts
.kind
);
3138 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3139 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
3141 mpfr_trunc (exp
, exp
);
3142 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
3144 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3146 mpfr_div (result
->value
.real
, x
->value
.real
, pow2
, GFC_RND_MODE
);
3148 mpfr_clears (exp
, absv
, pow2
, NULL
);
3152 /* mpfr_frexp() correctly handles zeros and NaNs. */
3153 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3157 return range_check (result
, "FRACTION");
3162 gfc_simplify_gamma (gfc_expr
*x
)
3166 if (x
->expr_type
!= EXPR_CONSTANT
)
3169 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3170 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3172 return range_check (result
, "GAMMA");
3177 gfc_simplify_huge (gfc_expr
*e
)
3182 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3183 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3188 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
3192 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
3204 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
3208 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3211 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3212 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
3213 return range_check (result
, "HYPOT");
3217 /* We use the processor's collating sequence, because all
3218 systems that gfortran currently works on are ASCII. */
3221 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
3227 if (e
->expr_type
!= EXPR_CONSTANT
)
3230 if (e
->value
.character
.length
!= 1)
3232 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
3233 return &gfc_bad_expr
;
3236 index
= e
->value
.character
.string
[0];
3238 if (warn_surprising
&& index
> 127)
3239 gfc_warning (OPT_Wsurprising
,
3240 "Argument of IACHAR function at %L outside of range 0..127",
3243 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
3245 return &gfc_bad_expr
;
3247 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3249 return range_check (result
, "IACHAR");
3254 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
3256 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3257 gcc_assert (result
->ts
.type
== BT_INTEGER
3258 && result
->expr_type
== EXPR_CONSTANT
);
3260 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3266 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3268 if (gfc_is_size_zero_array (array
))
3269 return gfc_get_int_expr (array
->ts
.kind
, NULL
, -1);
3271 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
3276 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
3278 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3279 gcc_assert (result
->ts
.type
== BT_INTEGER
3280 && result
->expr_type
== EXPR_CONSTANT
);
3282 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3288 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3290 if (gfc_is_size_zero_array (array
))
3291 return gfc_get_int_expr (array
->ts
.kind
, NULL
, 0);
3293 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
3298 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
3302 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3305 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3306 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3308 return range_check (result
, "IAND");
3313 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
3318 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3321 gfc_extract_int (y
, &pos
);
3323 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3325 result
= gfc_copy_expr (x
);
3327 convert_mpz_to_unsigned (result
->value
.integer
,
3328 gfc_integer_kinds
[k
].bit_size
);
3330 mpz_clrbit (result
->value
.integer
, pos
);
3332 gfc_convert_mpz_to_signed (result
->value
.integer
,
3333 gfc_integer_kinds
[k
].bit_size
);
3340 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
3347 if (x
->expr_type
!= EXPR_CONSTANT
3348 || y
->expr_type
!= EXPR_CONSTANT
3349 || z
->expr_type
!= EXPR_CONSTANT
)
3352 gfc_extract_int (y
, &pos
);
3353 gfc_extract_int (z
, &len
);
3355 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
3357 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3359 if (pos
+ len
> bitsize
)
3361 gfc_error ("Sum of second and third arguments of IBITS exceeds "
3362 "bit size at %L", &y
->where
);
3363 return &gfc_bad_expr
;
3366 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3367 convert_mpz_to_unsigned (result
->value
.integer
,
3368 gfc_integer_kinds
[k
].bit_size
);
3370 bits
= XCNEWVEC (int, bitsize
);
3372 for (i
= 0; i
< bitsize
; i
++)
3375 for (i
= 0; i
< len
; i
++)
3376 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
3378 for (i
= 0; i
< bitsize
; i
++)
3381 mpz_clrbit (result
->value
.integer
, i
);
3382 else if (bits
[i
] == 1)
3383 mpz_setbit (result
->value
.integer
, i
);
3385 gfc_internal_error ("IBITS: Bad bit");
3390 gfc_convert_mpz_to_signed (result
->value
.integer
,
3391 gfc_integer_kinds
[k
].bit_size
);
3398 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
3403 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3406 gfc_extract_int (y
, &pos
);
3408 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3410 result
= gfc_copy_expr (x
);
3412 convert_mpz_to_unsigned (result
->value
.integer
,
3413 gfc_integer_kinds
[k
].bit_size
);
3415 mpz_setbit (result
->value
.integer
, pos
);
3417 gfc_convert_mpz_to_signed (result
->value
.integer
,
3418 gfc_integer_kinds
[k
].bit_size
);
3425 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
3431 if (e
->expr_type
!= EXPR_CONSTANT
)
3434 if (e
->value
.character
.length
!= 1)
3436 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
3437 return &gfc_bad_expr
;
3440 index
= e
->value
.character
.string
[0];
3442 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
3444 return &gfc_bad_expr
;
3446 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3448 return range_check (result
, "ICHAR");
3453 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
3457 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3460 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3461 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3463 return range_check (result
, "IEOR");
3468 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
3471 int back
, len
, lensub
;
3472 int i
, j
, k
, count
, index
= 0, start
;
3474 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
3475 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
3478 if (b
!= NULL
&& b
->value
.logical
!= 0)
3483 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
3485 return &gfc_bad_expr
;
3487 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
3489 len
= x
->value
.character
.length
;
3490 lensub
= y
->value
.character
.length
;
3494 mpz_set_si (result
->value
.integer
, 0);
3502 mpz_set_si (result
->value
.integer
, 1);
3505 else if (lensub
== 1)
3507 for (i
= 0; i
< len
; i
++)
3509 for (j
= 0; j
< lensub
; j
++)
3511 if (y
->value
.character
.string
[j
]
3512 == x
->value
.character
.string
[i
])
3522 for (i
= 0; i
< len
; i
++)
3524 for (j
= 0; j
< lensub
; j
++)
3526 if (y
->value
.character
.string
[j
]
3527 == x
->value
.character
.string
[i
])
3532 for (k
= 0; k
< lensub
; k
++)
3534 if (y
->value
.character
.string
[k
]
3535 == x
->value
.character
.string
[k
+ start
])
3539 if (count
== lensub
)
3554 mpz_set_si (result
->value
.integer
, len
+ 1);
3557 else if (lensub
== 1)
3559 for (i
= 0; i
< len
; i
++)
3561 for (j
= 0; j
< lensub
; j
++)
3563 if (y
->value
.character
.string
[j
]
3564 == x
->value
.character
.string
[len
- i
])
3566 index
= len
- i
+ 1;
3574 for (i
= 0; i
< len
; i
++)
3576 for (j
= 0; j
< lensub
; j
++)
3578 if (y
->value
.character
.string
[j
]
3579 == x
->value
.character
.string
[len
- i
])
3582 if (start
<= len
- lensub
)
3585 for (k
= 0; k
< lensub
; k
++)
3586 if (y
->value
.character
.string
[k
]
3587 == x
->value
.character
.string
[k
+ start
])
3590 if (count
== lensub
)
3607 mpz_set_si (result
->value
.integer
, index
);
3608 return range_check (result
, "INDEX");
3613 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
3615 gfc_expr
*result
= NULL
;
3617 if (e
->expr_type
!= EXPR_CONSTANT
)
3620 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
3621 if (result
== &gfc_bad_expr
)
3622 return &gfc_bad_expr
;
3624 return range_check (result
, name
);
3629 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
3633 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
3635 return &gfc_bad_expr
;
3637 return simplify_intconv (e
, kind
, "INT");
3641 gfc_simplify_int2 (gfc_expr
*e
)
3643 return simplify_intconv (e
, 2, "INT2");
3648 gfc_simplify_int8 (gfc_expr
*e
)
3650 return simplify_intconv (e
, 8, "INT8");
3655 gfc_simplify_long (gfc_expr
*e
)
3657 return simplify_intconv (e
, 4, "LONG");
3662 gfc_simplify_ifix (gfc_expr
*e
)
3664 gfc_expr
*rtrunc
, *result
;
3666 if (e
->expr_type
!= EXPR_CONSTANT
)
3669 rtrunc
= gfc_copy_expr (e
);
3670 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3672 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3674 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3676 gfc_free_expr (rtrunc
);
3678 return range_check (result
, "IFIX");
3683 gfc_simplify_idint (gfc_expr
*e
)
3685 gfc_expr
*rtrunc
, *result
;
3687 if (e
->expr_type
!= EXPR_CONSTANT
)
3690 rtrunc
= gfc_copy_expr (e
);
3691 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3693 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3695 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3697 gfc_free_expr (rtrunc
);
3699 return range_check (result
, "IDINT");
3704 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
3708 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3711 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3712 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3714 return range_check (result
, "IOR");
3719 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
3721 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3722 gcc_assert (result
->ts
.type
== BT_INTEGER
3723 && result
->expr_type
== EXPR_CONSTANT
);
3725 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3731 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3733 if (gfc_is_size_zero_array (array
))
3734 return gfc_get_int_expr (array
->ts
.kind
, NULL
, 0);
3736 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3741 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3743 if (x
->expr_type
!= EXPR_CONSTANT
)
3746 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3747 mpz_cmp_si (x
->value
.integer
,
3748 LIBERROR_END
) == 0);
3753 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3755 if (x
->expr_type
!= EXPR_CONSTANT
)
3758 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3759 mpz_cmp_si (x
->value
.integer
,
3760 LIBERROR_EOR
) == 0);
3765 gfc_simplify_isnan (gfc_expr
*x
)
3767 if (x
->expr_type
!= EXPR_CONSTANT
)
3770 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3771 mpfr_nan_p (x
->value
.real
));
3775 /* Performs a shift on its first argument. Depending on the last
3776 argument, the shift can be arithmetic, i.e. with filling from the
3777 left like in the SHIFTA intrinsic. */
3779 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3780 bool arithmetic
, int direction
)
3783 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3785 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3788 gfc_extract_int (s
, &shift
);
3790 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3791 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3793 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3797 mpz_set (result
->value
.integer
, e
->value
.integer
);
3801 if (direction
> 0 && shift
< 0)
3803 /* Left shift, as in SHIFTL. */
3804 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3805 return &gfc_bad_expr
;
3807 else if (direction
< 0)
3809 /* Right shift, as in SHIFTR or SHIFTA. */
3812 gfc_error ("Second argument of %s is negative at %L",
3814 return &gfc_bad_expr
;
3820 ashift
= (shift
>= 0 ? shift
: -shift
);
3822 if (ashift
> bitsize
)
3824 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3825 "at %L", name
, &e
->where
);
3826 return &gfc_bad_expr
;
3829 bits
= XCNEWVEC (int, bitsize
);
3831 for (i
= 0; i
< bitsize
; i
++)
3832 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3837 for (i
= 0; i
< shift
; i
++)
3838 mpz_clrbit (result
->value
.integer
, i
);
3840 for (i
= 0; i
< bitsize
- shift
; i
++)
3843 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3845 mpz_setbit (result
->value
.integer
, i
+ shift
);
3851 if (arithmetic
&& bits
[bitsize
- 1])
3852 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3853 mpz_setbit (result
->value
.integer
, i
);
3855 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3856 mpz_clrbit (result
->value
.integer
, i
);
3858 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3861 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3863 mpz_setbit (result
->value
.integer
, i
- ashift
);
3867 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3875 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3877 return simplify_shift (e
, s
, "ISHFT", false, 0);
3882 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3884 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3889 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3891 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3896 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3898 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3903 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3905 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3910 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3912 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3917 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3920 int shift
, ashift
, isize
, ssize
, delta
, k
;
3923 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3926 gfc_extract_int (s
, &shift
);
3928 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3929 isize
= gfc_integer_kinds
[k
].bit_size
;
3933 if (sz
->expr_type
!= EXPR_CONSTANT
)
3936 gfc_extract_int (sz
, &ssize
);
3949 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3950 "BIT_SIZE of first argument at %C");
3952 gfc_error ("Absolute value of SHIFT shall be less than or equal "
3954 return &gfc_bad_expr
;
3957 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3959 mpz_set (result
->value
.integer
, e
->value
.integer
);
3964 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
3966 bits
= XCNEWVEC (int, ssize
);
3968 for (i
= 0; i
< ssize
; i
++)
3969 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3971 delta
= ssize
- ashift
;
3975 for (i
= 0; i
< delta
; i
++)
3978 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3980 mpz_setbit (result
->value
.integer
, i
+ shift
);
3983 for (i
= delta
; i
< ssize
; i
++)
3986 mpz_clrbit (result
->value
.integer
, i
- delta
);
3988 mpz_setbit (result
->value
.integer
, i
- delta
);
3993 for (i
= 0; i
< ashift
; i
++)
3996 mpz_clrbit (result
->value
.integer
, i
+ delta
);
3998 mpz_setbit (result
->value
.integer
, i
+ delta
);
4001 for (i
= ashift
; i
< ssize
; i
++)
4004 mpz_clrbit (result
->value
.integer
, i
+ shift
);
4006 mpz_setbit (result
->value
.integer
, i
+ shift
);
4010 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
4018 gfc_simplify_kind (gfc_expr
*e
)
4020 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
4025 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
4026 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
4028 gfc_expr
*l
, *u
, *result
;
4031 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4032 gfc_default_integer_kind
);
4034 return &gfc_bad_expr
;
4036 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4038 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
4039 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
4040 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
4044 gfc_expr
* dim
= result
;
4045 mpz_set_si (dim
->value
.integer
, d
);
4047 result
= simplify_size (array
, dim
, k
);
4048 gfc_free_expr (dim
);
4053 mpz_set_si (result
->value
.integer
, 1);
4058 /* Otherwise, we have a variable expression. */
4059 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
4062 if (!gfc_resolve_array_spec (as
, 0))
4065 /* The last dimension of an assumed-size array is special. */
4066 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
4067 || (coarray
&& d
== as
->rank
+ as
->corank
4068 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
4070 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
4072 gfc_free_expr (result
);
4073 return gfc_copy_expr (as
->lower
[d
-1]);
4079 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4081 /* Then, we need to know the extent of the given dimension. */
4082 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
4084 gfc_expr
*declared_bound
;
4086 bool constant_lbound
, constant_ubound
;
4091 gcc_assert (l
!= NULL
);
4093 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
4094 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
4096 empty_bound
= upper
? 0 : 1;
4097 declared_bound
= upper
? u
: l
;
4099 if ((!upper
&& !constant_lbound
)
4100 || (upper
&& !constant_ubound
))
4105 /* For {L,U}BOUND, the value depends on whether the array
4106 is empty. We can nevertheless simplify if the declared bound
4107 has the same value as that of an empty array, in which case
4108 the result isn't dependent on the array emptyness. */
4109 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
4110 mpz_set_si (result
->value
.integer
, empty_bound
);
4111 else if (!constant_lbound
|| !constant_ubound
)
4112 /* Array emptyness can't be determined, we can't simplify. */
4114 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
4115 mpz_set_si (result
->value
.integer
, empty_bound
);
4117 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4120 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4126 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d
- 1, &result
->value
.integer
, NULL
))
4130 mpz_set_si (result
->value
.integer
, (long int) 1);
4134 return range_check (result
, upper
? "UBOUND" : "LBOUND");
4137 gfc_free_expr (result
);
4143 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4149 if (array
->ts
.type
== BT_CLASS
)
4152 if (array
->expr_type
!= EXPR_VARIABLE
)
4159 /* Follow any component references. */
4160 as
= array
->symtree
->n
.sym
->as
;
4161 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4166 switch (ref
->u
.ar
.type
)
4173 /* We're done because 'as' has already been set in the
4174 previous iteration. */
4188 as
= ref
->u
.c
.component
->as
;
4200 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
4201 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
4205 || (as
->type
!= AS_DEFERRED
4206 && array
->expr_type
== EXPR_VARIABLE
4207 && !gfc_expr_attr (array
).allocatable
4208 && !gfc_expr_attr (array
).pointer
));
4212 /* Multi-dimensional bounds. */
4213 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4217 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4218 if (upper
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
4220 /* An error message will be emitted in
4221 check_assumed_size_reference (resolve.c). */
4222 return &gfc_bad_expr
;
4225 /* Simplify the bounds for each dimension. */
4226 for (d
= 0; d
< array
->rank
; d
++)
4228 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
4230 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4234 for (j
= 0; j
< d
; j
++)
4235 gfc_free_expr (bounds
[j
]);
4240 /* Allocate the result expression. */
4241 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4242 gfc_default_integer_kind
);
4244 return &gfc_bad_expr
;
4246 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
4248 /* The result is a rank 1 array; its size is the rank of the first
4249 argument to {L,U}BOUND. */
4251 e
->shape
= gfc_get_shape (1);
4252 mpz_init_set_ui (e
->shape
[0], array
->rank
);
4254 /* Create the constructor for this array. */
4255 for (d
= 0; d
< array
->rank
; d
++)
4256 gfc_constructor_append_expr (&e
->value
.constructor
,
4257 bounds
[d
], &e
->where
);
4263 /* A DIM argument is specified. */
4264 if (dim
->expr_type
!= EXPR_CONSTANT
)
4267 d
= mpz_get_si (dim
->value
.integer
);
4269 if ((d
< 1 || d
> array
->rank
)
4270 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
4272 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4273 return &gfc_bad_expr
;
4276 if (as
&& as
->type
== AS_ASSUMED_RANK
)
4279 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
4285 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4291 if (array
->expr_type
!= EXPR_VARIABLE
)
4294 /* Follow any component references. */
4295 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
4296 ? array
->ts
.u
.derived
->components
->as
4297 : array
->symtree
->n
.sym
->as
;
4298 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4303 switch (ref
->u
.ar
.type
)
4306 if (ref
->u
.ar
.as
->corank
> 0)
4308 gcc_assert (as
== ref
->u
.ar
.as
);
4315 /* We're done because 'as' has already been set in the
4316 previous iteration. */
4330 as
= ref
->u
.c
.component
->as
;
4343 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
4348 /* Multi-dimensional cobounds. */
4349 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4353 /* Simplify the cobounds for each dimension. */
4354 for (d
= 0; d
< as
->corank
; d
++)
4356 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
4357 upper
, as
, ref
, true);
4358 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4362 for (j
= 0; j
< d
; j
++)
4363 gfc_free_expr (bounds
[j
]);
4368 /* Allocate the result expression. */
4369 e
= gfc_get_expr ();
4370 e
->where
= array
->where
;
4371 e
->expr_type
= EXPR_ARRAY
;
4372 e
->ts
.type
= BT_INTEGER
;
4373 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
4374 gfc_default_integer_kind
);
4378 return &gfc_bad_expr
;
4382 /* The result is a rank 1 array; its size is the rank of the first
4383 argument to {L,U}COBOUND. */
4385 e
->shape
= gfc_get_shape (1);
4386 mpz_init_set_ui (e
->shape
[0], as
->corank
);
4388 /* Create the constructor for this array. */
4389 for (d
= 0; d
< as
->corank
; d
++)
4390 gfc_constructor_append_expr (&e
->value
.constructor
,
4391 bounds
[d
], &e
->where
);
4396 /* A DIM argument is specified. */
4397 if (dim
->expr_type
!= EXPR_CONSTANT
)
4400 d
= mpz_get_si (dim
->value
.integer
);
4402 if (d
< 1 || d
> as
->corank
)
4404 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4405 return &gfc_bad_expr
;
4408 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
4414 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4416 return simplify_bound (array
, dim
, kind
, 0);
4421 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4423 return simplify_cobound (array
, dim
, kind
, 0);
4427 gfc_simplify_leadz (gfc_expr
*e
)
4429 unsigned long lz
, bs
;
4432 if (e
->expr_type
!= EXPR_CONSTANT
)
4435 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4436 bs
= gfc_integer_kinds
[i
].bit_size
;
4437 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
4439 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
4442 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
4444 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
4449 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
4452 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
4455 return &gfc_bad_expr
;
4457 if (e
->expr_type
== EXPR_CONSTANT
)
4459 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4460 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
4461 return range_check (result
, "LEN");
4463 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
4464 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
4465 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
4467 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4468 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
4469 return range_check (result
, "LEN");
4471 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
4472 && e
->symtree
->n
.sym
4473 && e
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
4474 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
4475 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
4476 && e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
4477 && UNLIMITED_POLY (e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
))
4479 /* The expression in assoc->target points to a ref to the _data component
4480 of the unlimited polymorphic entity. To get the _len component the last
4481 _data ref needs to be stripped and a ref to the _len component added. */
4482 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
);
4489 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
4492 size_t count
, len
, i
;
4493 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
4496 return &gfc_bad_expr
;
4498 if (e
->expr_type
!= EXPR_CONSTANT
)
4501 len
= e
->value
.character
.length
;
4502 for (count
= 0, i
= 1; i
<= len
; i
++)
4503 if (e
->value
.character
.string
[len
- i
] == ' ')
4508 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
4509 return range_check (result
, "LEN_TRIM");
4513 gfc_simplify_lgamma (gfc_expr
*x
)
4518 if (x
->expr_type
!= EXPR_CONSTANT
)
4521 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4522 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
4524 return range_check (result
, "LGAMMA");
4529 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
4531 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4534 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4535 gfc_compare_string (a
, b
) >= 0);
4540 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
4542 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4545 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4546 gfc_compare_string (a
, b
) > 0);
4551 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
4553 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4556 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4557 gfc_compare_string (a
, b
) <= 0);
4562 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
4564 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4567 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4568 gfc_compare_string (a
, b
) < 0);
4573 gfc_simplify_log (gfc_expr
*x
)
4577 if (x
->expr_type
!= EXPR_CONSTANT
)
4580 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4585 if (mpfr_sgn (x
->value
.real
) <= 0)
4587 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4588 "to zero", &x
->where
);
4589 gfc_free_expr (result
);
4590 return &gfc_bad_expr
;
4593 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4597 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
4598 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
4600 gfc_error ("Complex argument of LOG at %L cannot be zero",
4602 gfc_free_expr (result
);
4603 return &gfc_bad_expr
;
4606 gfc_set_model_kind (x
->ts
.kind
);
4607 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
4611 gfc_internal_error ("gfc_simplify_log: bad type");
4614 return range_check (result
, "LOG");
4619 gfc_simplify_log10 (gfc_expr
*x
)
4623 if (x
->expr_type
!= EXPR_CONSTANT
)
4626 if (mpfr_sgn (x
->value
.real
) <= 0)
4628 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4629 "to zero", &x
->where
);
4630 return &gfc_bad_expr
;
4633 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4634 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4636 return range_check (result
, "LOG10");
4641 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
4645 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
4647 return &gfc_bad_expr
;
4649 if (e
->expr_type
!= EXPR_CONSTANT
)
4652 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
4657 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
4660 int row
, result_rows
, col
, result_columns
;
4661 int stride_a
, offset_a
, stride_b
, offset_b
;
4663 if (!is_constant_array_expr (matrix_a
)
4664 || !is_constant_array_expr (matrix_b
))
4667 /* MATMUL should do mixed-mode arithmetic. Set the result type. */
4668 if (matrix_a
->ts
.type
!= matrix_b
->ts
.type
)
4671 e
.expr_type
= EXPR_OP
;
4672 gfc_clear_ts (&e
.ts
);
4673 e
.value
.op
.op
= INTRINSIC_NONE
;
4674 e
.value
.op
.op1
= matrix_a
;
4675 e
.value
.op
.op2
= matrix_b
;
4676 gfc_type_convert_binary (&e
, 1);
4677 result
= gfc_get_array_expr (e
.ts
.type
, e
.ts
.kind
, &matrix_a
->where
);
4681 result
= gfc_get_array_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
4685 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
4688 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4690 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4693 result
->shape
= gfc_get_shape (result
->rank
);
4694 mpz_init_set_si (result
->shape
[0], result_columns
);
4696 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
4698 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4700 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4704 result
->shape
= gfc_get_shape (result
->rank
);
4705 mpz_init_set_si (result
->shape
[0], result_rows
);
4707 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
4709 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4710 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4711 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4712 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4715 result
->shape
= gfc_get_shape (result
->rank
);
4716 mpz_init_set_si (result
->shape
[0], result_rows
);
4717 mpz_init_set_si (result
->shape
[1], result_columns
);
4722 offset_a
= offset_b
= 0;
4723 for (col
= 0; col
< result_columns
; ++col
)
4727 for (row
= 0; row
< result_rows
; ++row
)
4729 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
4730 matrix_b
, 1, offset_b
, false);
4731 gfc_constructor_append_expr (&result
->value
.constructor
,
4737 offset_b
+= stride_b
;
4745 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
4750 if (i
->expr_type
!= EXPR_CONSTANT
)
4753 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
4755 return &gfc_bad_expr
;
4756 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4758 bool fail
= gfc_extract_int (i
, &arg
);
4761 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4763 /* MASKR(n) = 2^n - 1 */
4764 mpz_set_ui (result
->value
.integer
, 1);
4765 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4766 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4768 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4775 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4781 if (i
->expr_type
!= EXPR_CONSTANT
)
4784 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4786 return &gfc_bad_expr
;
4787 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4789 bool fail
= gfc_extract_int (i
, &arg
);
4792 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4794 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4795 mpz_init_set_ui (z
, 1);
4796 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4797 mpz_set_ui (result
->value
.integer
, 1);
4798 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4799 gfc_integer_kinds
[k
].bit_size
- arg
);
4800 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4803 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4810 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4813 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4815 if (mask
->expr_type
== EXPR_CONSTANT
)
4816 return gfc_get_parentheses (gfc_copy_expr (mask
->value
.logical
4817 ? tsource
: fsource
));
4819 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4820 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4823 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4825 if (tsource
->ts
.type
== BT_DERIVED
)
4826 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4827 else if (tsource
->ts
.type
== BT_CHARACTER
)
4828 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4830 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4831 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4832 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4836 if (mask_ctor
->expr
->value
.logical
)
4837 gfc_constructor_append_expr (&result
->value
.constructor
,
4838 gfc_copy_expr (tsource_ctor
->expr
),
4841 gfc_constructor_append_expr (&result
->value
.constructor
,
4842 gfc_copy_expr (fsource_ctor
->expr
),
4844 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4845 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4846 mask_ctor
= gfc_constructor_next (mask_ctor
);
4849 result
->shape
= gfc_get_shape (1);
4850 gfc_array_size (result
, &result
->shape
[0]);
4857 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4859 mpz_t arg1
, arg2
, mask
;
4862 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4863 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4866 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4868 /* Convert all argument to unsigned. */
4869 mpz_init_set (arg1
, i
->value
.integer
);
4870 mpz_init_set (arg2
, j
->value
.integer
);
4871 mpz_init_set (mask
, mask_expr
->value
.integer
);
4873 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4874 mpz_and (arg1
, arg1
, mask
);
4875 mpz_com (mask
, mask
);
4876 mpz_and (arg2
, arg2
, mask
);
4877 mpz_ior (result
->value
.integer
, arg1
, arg2
);
4887 /* Selects between current value and extremum for simplify_min_max
4888 and simplify_minval_maxval. */
4890 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
)
4894 switch (arg
->ts
.type
)
4897 ret
= mpz_cmp (arg
->value
.integer
,
4898 extremum
->value
.integer
) * sign
;
4900 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
4904 if (mpfr_nan_p (extremum
->value
.real
))
4907 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
4909 else if (mpfr_nan_p (arg
->value
.real
))
4913 ret
= mpfr_cmp (arg
->value
.real
, extremum
->value
.real
) * sign
;
4915 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
4920 #define LENGTH(x) ((x)->value.character.length)
4921 #define STRING(x) ((x)->value.character.string)
4922 if (LENGTH (extremum
) < LENGTH(arg
))
4924 gfc_char_t
*tmp
= STRING(extremum
);
4926 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
4927 memcpy (STRING(extremum
), tmp
,
4928 LENGTH(extremum
) * sizeof (gfc_char_t
));
4929 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
4930 LENGTH(arg
) - LENGTH(extremum
));
4931 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
4932 LENGTH(extremum
) = LENGTH(arg
);
4935 ret
= gfc_compare_string (arg
, extremum
) * sign
;
4938 free (STRING(extremum
));
4939 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
4940 memcpy (STRING(extremum
), STRING(arg
),
4941 LENGTH(arg
) * sizeof (gfc_char_t
));
4942 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
4943 LENGTH(extremum
) - LENGTH(arg
));
4944 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
4951 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4957 /* This function is special since MAX() can take any number of
4958 arguments. The simplified expression is a rewritten version of the
4959 argument list containing at most one constant element. Other
4960 constant elements are deleted. Because the argument list has
4961 already been checked, this function always succeeds. sign is 1 for
4962 MAX(), -1 for MIN(). */
4965 simplify_min_max (gfc_expr
*expr
, int sign
)
4967 gfc_actual_arglist
*arg
, *last
, *extremum
;
4968 gfc_intrinsic_sym
* specific
;
4972 specific
= expr
->value
.function
.isym
;
4974 arg
= expr
->value
.function
.actual
;
4976 for (; arg
; last
= arg
, arg
= arg
->next
)
4978 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
4981 if (extremum
== NULL
)
4987 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
4989 /* Delete the extra constant argument. */
4990 last
->next
= arg
->next
;
4993 gfc_free_actual_arglist (arg
);
4997 /* If there is one value left, replace the function call with the
4999 if (expr
->value
.function
.actual
->next
!= NULL
)
5002 /* Convert to the correct type and kind. */
5003 if (expr
->ts
.type
!= BT_UNKNOWN
)
5004 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
5005 expr
->ts
.type
, expr
->ts
.kind
);
5007 if (specific
->ts
.type
!= BT_UNKNOWN
)
5008 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
5009 specific
->ts
.type
, specific
->ts
.kind
);
5011 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
5016 gfc_simplify_min (gfc_expr
*e
)
5018 return simplify_min_max (e
, -1);
5023 gfc_simplify_max (gfc_expr
*e
)
5025 return simplify_min_max (e
, 1);
5028 /* Helper function for gfc_simplify_minval. */
5031 gfc_min (gfc_expr
*op1
, gfc_expr
*op2
)
5033 min_max_choose (op1
, op2
, -1);
5034 gfc_free_expr (op1
);
5038 /* Simplify minval for constant arrays. */
5041 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5043 if (gfc_is_size_zero_array (array
))
5048 i
= gfc_validate_kind (array
->ts
.type
, array
->ts
.kind
, false);
5049 result
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
,
5051 switch (array
->ts
.type
)
5054 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
5058 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
5062 /* If ARRAY has size zero and type character, the result has the
5063 value of a string of characters of length LEN (ARRAY), with
5064 each character equal to CHAR(n - 1, KIND (ARRAY)), where n is
5065 the number of characters in the collating sequence for
5066 characters with the kind type parameter of ARRAY. */
5067 gfc_error ("MINVAL(string) at %L is not implemented, yet!",
5069 gfc_free_expr (result
);
5070 return &gfc_bad_expr
;
5080 return simplify_transformation (array
, dim
, mask
, INT_MAX
, gfc_min
);
5083 /* Helper function for gfc_simplify_maxval. */
5086 gfc_max (gfc_expr
*op1
, gfc_expr
*op2
)
5088 min_max_choose (op1
, op2
, 1);
5089 gfc_free_expr (op1
);
5094 /* Simplify maxval for constant arrays. */
5097 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5099 if (gfc_is_size_zero_array (array
))
5104 i
= gfc_validate_kind (array
->ts
.type
, array
->ts
.kind
, false);
5105 result
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
,
5107 switch (array
->ts
.type
)
5110 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
5114 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
5115 mpfr_neg (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
5119 /* If ARRAY has size zero and type character, the result has the
5120 value of a string of characters of length LEN (ARRAY), with
5121 each character equal to CHAR (0, KIND (ARRAY)). */
5122 gfc_error ("MAXVAL(string) at %L is not implemented, yet!",
5124 gfc_free_expr (result
);
5125 return &gfc_bad_expr
;
5135 return simplify_transformation (array
, dim
, mask
, INT_MIN
, gfc_max
);
5139 /* Transform minloc or maxloc of an array, according to MASK,
5140 to the scalar result. This code is mostly identical to
5141 simplify_transformation_to_scalar. */
5144 simplify_minmaxloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
5145 gfc_expr
*extremum
, int sign
)
5148 gfc_constructor
*array_ctor
, *mask_ctor
;
5151 mpz_set_si (result
->value
.integer
, 0);
5154 /* Shortcut for constant .FALSE. MASK. */
5156 && mask
->expr_type
== EXPR_CONSTANT
5157 && !mask
->value
.logical
)
5160 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5161 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5162 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5166 mpz_init_set_si (count
, 0);
5169 mpz_add_ui (count
, count
, 1);
5170 a
= array_ctor
->expr
;
5171 array_ctor
= gfc_constructor_next (array_ctor
);
5172 /* A constant MASK equals .TRUE. here and can be ignored. */
5175 m
= mask_ctor
->expr
;
5176 mask_ctor
= gfc_constructor_next (mask_ctor
);
5177 if (!m
->value
.logical
)
5180 if (min_max_choose (a
, extremum
, sign
) > 0)
5181 mpz_set (result
->value
.integer
, count
);
5184 gfc_free_expr (extremum
);
5188 /* Simplify minloc / maxloc in the absence of a dim argument. */
5191 simplify_minmaxloc_nodim (gfc_expr
*result
, gfc_expr
*extremum
,
5192 gfc_expr
*array
, gfc_expr
*mask
, int sign
)
5194 ssize_t res
[GFC_MAX_DIMENSIONS
];
5196 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5197 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5198 sstride
[GFC_MAX_DIMENSIONS
];
5203 for (i
= 0; i
<array
->rank
; i
++)
5206 /* Shortcut for constant .FALSE. MASK. */
5208 && mask
->expr_type
== EXPR_CONSTANT
5209 && !mask
->value
.logical
)
5212 for (i
= 0; i
< array
->rank
; i
++)
5215 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5216 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5221 continue_loop
= true;
5222 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5223 if (mask
&& mask
->rank
> 0)
5224 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5228 /* Loop over the array elements (and mask), keeping track of
5229 the indices to return. */
5230 while (continue_loop
)
5234 a
= array_ctor
->expr
;
5237 m
= mask_ctor
->expr
;
5238 ma
= m
->value
.logical
;
5239 mask_ctor
= gfc_constructor_next (mask_ctor
);
5244 if (ma
&& min_max_choose (a
, extremum
, sign
) > 0)
5246 for (i
= 0; i
<array
->rank
; i
++)
5249 array_ctor
= gfc_constructor_next (array_ctor
);
5251 } while (count
[0] != extent
[0]);
5255 /* When we get to the end of a dimension, reset it and increment
5256 the next dimension. */
5259 if (n
>= array
->rank
)
5261 continue_loop
= false;
5266 } while (count
[n
] == extent
[n
]);
5270 gfc_free_expr (extremum
);
5271 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5272 for (i
= 0; i
<array
->rank
; i
++)
5275 r_expr
= result_ctor
->expr
;
5276 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5277 result_ctor
= gfc_constructor_next (result_ctor
);
5282 /* Helper function for gfc_simplify_minmaxloc - build an array
5283 expression with n elements. */
5286 new_array (bt type
, int kind
, int n
, locus
*where
)
5291 result
= gfc_get_array_expr (type
, kind
, where
);
5293 result
->shape
= gfc_get_shape(1);
5294 mpz_init_set_si (result
->shape
[0], n
);
5295 for (i
= 0; i
< n
; i
++)
5297 gfc_constructor_append_expr (&result
->value
.constructor
,
5298 gfc_get_constant_expr (type
, kind
, where
),
5305 /* Simplify minloc and maxloc. This code is mostly identical to
5306 simplify_transformation_to_array. */
5309 simplify_minmaxloc_to_array (gfc_expr
*result
, gfc_expr
*array
,
5310 gfc_expr
*dim
, gfc_expr
*mask
,
5311 gfc_expr
*extremum
, int sign
)
5314 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5315 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5316 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5318 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5319 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5320 tmpstride
[GFC_MAX_DIMENSIONS
];
5322 /* Shortcut for constant .FALSE. MASK. */
5324 && mask
->expr_type
== EXPR_CONSTANT
5325 && !mask
->value
.logical
)
5328 /* Build an indexed table for array element expressions to minimize
5329 linked-list traversal. Masked elements are set to NULL. */
5330 gfc_array_size (array
, &size
);
5331 arraysize
= mpz_get_ui (size
);
5334 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5336 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5338 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5339 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5341 for (i
= 0; i
< arraysize
; ++i
)
5343 arrayvec
[i
] = array_ctor
->expr
;
5344 array_ctor
= gfc_constructor_next (array_ctor
);
5348 if (!mask_ctor
->expr
->value
.logical
)
5351 mask_ctor
= gfc_constructor_next (mask_ctor
);
5355 /* Same for the result expression. */
5356 gfc_array_size (result
, &size
);
5357 resultsize
= mpz_get_ui (size
);
5360 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5361 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5362 for (i
= 0; i
< resultsize
; ++i
)
5364 resultvec
[i
] = result_ctor
->expr
;
5365 result_ctor
= gfc_constructor_next (result_ctor
);
5368 gfc_extract_int (dim
, &dim_index
);
5369 dim_index
-= 1; /* zero-base index */
5373 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5376 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5379 dim_extent
= mpz_get_si (array
->shape
[i
]);
5380 dim_stride
= tmpstride
[i
];
5384 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5385 sstride
[n
] = tmpstride
[i
];
5386 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5396 ex
= gfc_copy_expr (extremum
);
5397 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5399 if (*src
&& min_max_choose (*src
, ex
, sign
) > 0)
5400 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5409 while (!done
&& count
[n
] == extent
[n
])
5412 base
-= sstride
[n
] * extent
[n
];
5413 dest
-= dstride
[n
] * extent
[n
];
5416 if (n
< result
->rank
)
5418 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5419 times, we'd warn for the last iteration, because the
5420 array index will have already been incremented to the
5421 array sizes, and we can't tell that this must make
5422 the test against result->rank false, because ranks
5423 must not exceed GFC_MAX_DIMENSIONS. */
5424 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5435 /* Place updated expression in result constructor. */
5436 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5437 for (i
= 0; i
< resultsize
; ++i
)
5439 result_ctor
->expr
= resultvec
[i
];
5440 result_ctor
= gfc_constructor_next (result_ctor
);
5449 /* Simplify minloc and maxloc for constant arrays. */
5452 gfc_simplify_minmaxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
5453 gfc_expr
*kind
, int sign
)
5460 if (!is_constant_array_expr (array
)
5461 || !gfc_is_constant_expr (dim
))
5465 && !is_constant_array_expr (mask
)
5466 && mask
->expr_type
!= EXPR_CONSTANT
)
5471 if (gfc_extract_int (kind
, &ikind
, -1))
5475 ikind
= gfc_default_integer_kind
;
5484 extremum
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
5485 init_result_expr (extremum
, init_val
, array
);
5489 result
= transformational_result (array
, dim
, BT_INTEGER
,
5490 ikind
, &array
->where
);
5491 init_result_expr (result
, 0, array
);
5493 if (array
->rank
== 1)
5494 return simplify_minmaxloc_to_scalar (result
, array
, mask
, extremum
, sign
);
5496 return simplify_minmaxloc_to_array (result
, array
, dim
, mask
, extremum
, sign
);
5500 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5501 return simplify_minmaxloc_nodim (result
, extremum
, array
, mask
, sign
);
5506 gfc_simplify_minloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5507 gfc_expr
*back ATTRIBUTE_UNUSED
)
5509 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, -1);
5513 gfc_simplify_maxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5514 gfc_expr
*back ATTRIBUTE_UNUSED
)
5516 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, 1);
5520 gfc_simplify_maxexponent (gfc_expr
*x
)
5522 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5523 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5524 gfc_real_kinds
[i
].max_exponent
);
5529 gfc_simplify_minexponent (gfc_expr
*x
)
5531 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5532 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5533 gfc_real_kinds
[i
].min_exponent
);
5538 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
5543 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
5546 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
5547 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
5552 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
5554 /* Result is processor-dependent. */
5555 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
5556 gfc_free_expr (result
);
5557 return &gfc_bad_expr
;
5559 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
5563 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
5565 /* Result is processor-dependent. */
5566 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
5567 gfc_free_expr (result
);
5568 return &gfc_bad_expr
;
5571 gfc_set_model_kind (kind
);
5572 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
5577 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
5580 return range_check (result
, "MOD");
5585 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
5590 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
5593 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
5594 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
5599 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
5601 /* Result is processor-dependent. This processor just opts
5602 to not handle it at all. */
5603 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
5604 gfc_free_expr (result
);
5605 return &gfc_bad_expr
;
5607 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
5612 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
5614 /* Result is processor-dependent. */
5615 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
5616 gfc_free_expr (result
);
5617 return &gfc_bad_expr
;
5620 gfc_set_model_kind (kind
);
5621 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
5623 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
5625 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
5626 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
5630 mpfr_copysign (result
->value
.real
, result
->value
.real
,
5631 p
->value
.real
, GFC_RND_MODE
);
5635 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
5638 return range_check (result
, "MODULO");
5643 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
5646 mp_exp_t emin
, emax
;
5649 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
5652 result
= gfc_copy_expr (x
);
5654 /* Save current values of emin and emax. */
5655 emin
= mpfr_get_emin ();
5656 emax
= mpfr_get_emax ();
5658 /* Set emin and emax for the current model number. */
5659 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
5660 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
5661 mpfr_get_prec(result
->value
.real
) + 1);
5662 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
5663 mpfr_check_range (result
->value
.real
, 0, GMP_RNDU
);
5665 if (mpfr_sgn (s
->value
.real
) > 0)
5667 mpfr_nextabove (result
->value
.real
);
5668 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
5672 mpfr_nextbelow (result
->value
.real
);
5673 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
5676 mpfr_set_emin (emin
);
5677 mpfr_set_emax (emax
);
5679 /* Only NaN can occur. Do not use range check as it gives an
5680 error for denormal numbers. */
5681 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
5683 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
5684 gfc_free_expr (result
);
5685 return &gfc_bad_expr
;
5693 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
5695 gfc_expr
*itrunc
, *result
;
5698 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
5700 return &gfc_bad_expr
;
5702 if (e
->expr_type
!= EXPR_CONSTANT
)
5705 itrunc
= gfc_copy_expr (e
);
5706 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
5708 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
5709 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
5711 gfc_free_expr (itrunc
);
5713 return range_check (result
, name
);
5718 gfc_simplify_new_line (gfc_expr
*e
)
5722 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
5723 result
->value
.character
.string
[0] = '\n';
5730 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
5732 return simplify_nint ("NINT", e
, k
);
5737 gfc_simplify_idnint (gfc_expr
*e
)
5739 return simplify_nint ("IDNINT", e
, NULL
);
5744 add_squared (gfc_expr
*result
, gfc_expr
*e
)
5748 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
5749 gcc_assert (result
->ts
.type
== BT_REAL
5750 && result
->expr_type
== EXPR_CONSTANT
);
5752 gfc_set_model_kind (result
->ts
.kind
);
5754 mpfr_pow_ui (tmp
, e
->value
.real
, 2, GFC_RND_MODE
);
5755 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
5764 do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
5766 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
5767 gcc_assert (result
->ts
.type
== BT_REAL
5768 && result
->expr_type
== EXPR_CONSTANT
);
5770 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
5771 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
5777 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
5781 if (gfc_is_size_zero_array (e
))
5784 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
5785 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5789 if (!is_constant_array_expr (e
)
5790 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
5793 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
5794 init_result_expr (result
, 0, NULL
);
5796 if (!dim
|| e
->rank
== 1)
5798 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
5800 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
5803 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
5804 add_squared
, &do_sqrt
);
5811 gfc_simplify_not (gfc_expr
*e
)
5815 if (e
->expr_type
!= EXPR_CONSTANT
)
5818 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
5819 mpz_com (result
->value
.integer
, e
->value
.integer
);
5821 return range_check (result
, "NOT");
5826 gfc_simplify_null (gfc_expr
*mold
)
5832 result
= gfc_copy_expr (mold
);
5833 result
->expr_type
= EXPR_NULL
;
5836 result
= gfc_get_null_expr (NULL
);
5843 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
5847 if (flag_coarray
== GFC_FCOARRAY_NONE
)
5849 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
5850 return &gfc_bad_expr
;
5853 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
5856 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
5859 /* FIXME: gfc_current_locus is wrong. */
5860 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
5861 &gfc_current_locus
);
5863 if (failed
&& failed
->value
.logical
!= 0)
5864 mpz_set_si (result
->value
.integer
, 0);
5866 mpz_set_si (result
->value
.integer
, 1);
5873 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
5878 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
5881 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
5886 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
5887 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
5888 return range_check (result
, "OR");
5891 return gfc_get_logical_expr (kind
, &x
->where
,
5892 x
->value
.logical
|| y
->value
.logical
);
5900 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
5903 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
5905 if (!is_constant_array_expr (array
)
5906 || !is_constant_array_expr (vector
)
5907 || (!gfc_is_constant_expr (mask
)
5908 && !is_constant_array_expr (mask
)))
5911 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
5912 if (array
->ts
.type
== BT_DERIVED
)
5913 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
5915 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5916 vector_ctor
= vector
5917 ? gfc_constructor_first (vector
->value
.constructor
)
5920 if (mask
->expr_type
== EXPR_CONSTANT
5921 && mask
->value
.logical
)
5923 /* Copy all elements of ARRAY to RESULT. */
5926 gfc_constructor_append_expr (&result
->value
.constructor
,
5927 gfc_copy_expr (array_ctor
->expr
),
5930 array_ctor
= gfc_constructor_next (array_ctor
);
5931 vector_ctor
= gfc_constructor_next (vector_ctor
);
5934 else if (mask
->expr_type
== EXPR_ARRAY
)
5936 /* Copy only those elements of ARRAY to RESULT whose
5937 MASK equals .TRUE.. */
5938 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5941 if (mask_ctor
->expr
->value
.logical
)
5943 gfc_constructor_append_expr (&result
->value
.constructor
,
5944 gfc_copy_expr (array_ctor
->expr
),
5946 vector_ctor
= gfc_constructor_next (vector_ctor
);
5949 array_ctor
= gfc_constructor_next (array_ctor
);
5950 mask_ctor
= gfc_constructor_next (mask_ctor
);
5954 /* Append any left-over elements from VECTOR to RESULT. */
5957 gfc_constructor_append_expr (&result
->value
.constructor
,
5958 gfc_copy_expr (vector_ctor
->expr
),
5960 vector_ctor
= gfc_constructor_next (vector_ctor
);
5963 result
->shape
= gfc_get_shape (1);
5964 gfc_array_size (result
, &result
->shape
[0]);
5966 if (array
->ts
.type
== BT_CHARACTER
)
5967 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
5974 do_xor (gfc_expr
*result
, gfc_expr
*e
)
5976 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
5977 gcc_assert (result
->ts
.type
== BT_LOGICAL
5978 && result
->expr_type
== EXPR_CONSTANT
);
5980 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
5987 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
5989 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
5994 gfc_simplify_popcnt (gfc_expr
*e
)
5999 if (e
->expr_type
!= EXPR_CONSTANT
)
6002 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6004 /* Convert argument to unsigned, then count the '1' bits. */
6005 mpz_init_set (x
, e
->value
.integer
);
6006 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
6007 res
= mpz_popcount (x
);
6010 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
6015 gfc_simplify_poppar (gfc_expr
*e
)
6020 if (e
->expr_type
!= EXPR_CONSTANT
)
6023 popcnt
= gfc_simplify_popcnt (e
);
6024 gcc_assert (popcnt
);
6026 bool fail
= gfc_extract_int (popcnt
, &i
);
6029 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
6034 gfc_simplify_precision (gfc_expr
*e
)
6036 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6037 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
6038 gfc_real_kinds
[i
].precision
);
6043 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6045 if (gfc_is_size_zero_array (array
))
6049 result
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
,
6051 switch (array
->ts
.type
)
6054 mpz_set_ui (result
->value
.integer
, 1);
6058 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
6062 mpc_set_ui (result
->value
.complex, 1, GFC_MPC_RND_MODE
);
6072 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
6077 gfc_simplify_radix (gfc_expr
*e
)
6080 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6085 i
= gfc_integer_kinds
[i
].radix
;
6089 i
= gfc_real_kinds
[i
].radix
;
6096 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6101 gfc_simplify_range (gfc_expr
*e
)
6104 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6109 i
= gfc_integer_kinds
[i
].range
;
6114 i
= gfc_real_kinds
[i
].range
;
6121 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6126 gfc_simplify_rank (gfc_expr
*e
)
6132 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
6137 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
6139 gfc_expr
*result
= NULL
;
6142 if (e
->ts
.type
== BT_COMPLEX
)
6143 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
6145 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
6148 return &gfc_bad_expr
;
6150 if (e
->expr_type
!= EXPR_CONSTANT
)
6153 if (convert_boz (e
, kind
) == &gfc_bad_expr
)
6154 return &gfc_bad_expr
;
6156 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
6157 if (result
== &gfc_bad_expr
)
6158 return &gfc_bad_expr
;
6160 return range_check (result
, "REAL");
6165 gfc_simplify_realpart (gfc_expr
*e
)
6169 if (e
->expr_type
!= EXPR_CONSTANT
)
6172 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6173 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
6175 return range_check (result
, "REALPART");
6179 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
6184 bool have_length
= false;
6186 /* If NCOPIES isn't a constant, there's nothing we can do. */
6187 if (n
->expr_type
!= EXPR_CONSTANT
)
6190 /* If NCOPIES is negative, it's an error. */
6191 if (mpz_sgn (n
->value
.integer
) < 0)
6193 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6195 return &gfc_bad_expr
;
6198 /* If we don't know the character length, we can do no more. */
6199 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
6200 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6202 len
= gfc_mpz_get_hwi (e
->ts
.u
.cl
->length
->value
.integer
);
6205 else if (e
->expr_type
== EXPR_CONSTANT
6206 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
6208 len
= e
->value
.character
.length
;
6213 /* If the source length is 0, any value of NCOPIES is valid
6214 and everything behaves as if NCOPIES == 0. */
6217 mpz_set_ui (ncopies
, 0);
6219 mpz_set (ncopies
, n
->value
.integer
);
6221 /* Check that NCOPIES isn't too large. */
6227 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6229 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6233 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
6234 e
->ts
.u
.cl
->length
->value
.integer
);
6239 gfc_mpz_set_hwi (mlen
, len
);
6240 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
6244 /* The check itself. */
6245 if (mpz_cmp (ncopies
, max
) > 0)
6248 mpz_clear (ncopies
);
6249 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6251 return &gfc_bad_expr
;
6256 mpz_clear (ncopies
);
6258 /* For further simplification, we need the character string to be
6260 if (e
->expr_type
!= EXPR_CONSTANT
)
6265 (e
->ts
.u
.cl
->length
&&
6266 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
) != 0))
6268 bool fail
= gfc_extract_hwi (n
, &ncop
);
6275 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
6277 len
= e
->value
.character
.length
;
6278 gfc_charlen_t nlen
= ncop
* len
;
6280 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6281 (2**28 elements * 4 bytes (wide chars) per element) defer to
6282 runtime instead of consuming (unbounded) memory and CPU at
6284 if (nlen
> 268435456)
6286 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6287 " deferred to runtime, expect bugs", &e
->where
);
6291 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
6292 for (size_t i
= 0; i
< (size_t) ncop
; i
++)
6293 for (size_t j
= 0; j
< (size_t) len
; j
++)
6294 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
6296 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
6301 /* This one is a bear, but mainly has to do with shuffling elements. */
6304 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
6305 gfc_expr
*pad
, gfc_expr
*order_exp
)
6307 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
6308 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
6312 gfc_expr
*e
, *result
;
6314 /* Check that argument expression types are OK. */
6315 if (!is_constant_array_expr (source
)
6316 || !is_constant_array_expr (shape_exp
)
6317 || !is_constant_array_expr (pad
)
6318 || !is_constant_array_expr (order_exp
))
6321 if (source
->shape
== NULL
)
6324 /* Proceed with simplification, unpacking the array. */
6331 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
6335 gfc_extract_int (e
, &shape
[rank
]);
6337 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
6338 gcc_assert (shape
[rank
] >= 0);
6343 gcc_assert (rank
> 0);
6345 /* Now unpack the order array if present. */
6346 if (order_exp
== NULL
)
6348 for (i
= 0; i
< rank
; i
++)
6353 for (i
= 0; i
< rank
; i
++)
6356 for (i
= 0; i
< rank
; i
++)
6358 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
6361 gfc_extract_int (e
, &order
[i
]);
6363 gcc_assert (order
[i
] >= 1 && order
[i
] <= rank
);
6365 gcc_assert (x
[order
[i
]] == 0);
6370 /* Count the elements in the source and padding arrays. */
6375 gfc_array_size (pad
, &size
);
6376 npad
= mpz_get_ui (size
);
6380 gfc_array_size (source
, &size
);
6381 nsource
= mpz_get_ui (size
);
6384 /* If it weren't for that pesky permutation we could just loop
6385 through the source and round out any shortage with pad elements.
6386 But no, someone just had to have the compiler do something the
6387 user should be doing. */
6389 for (i
= 0; i
< rank
; i
++)
6392 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6394 if (source
->ts
.type
== BT_DERIVED
)
6395 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6396 result
->rank
= rank
;
6397 result
->shape
= gfc_get_shape (rank
);
6398 for (i
= 0; i
< rank
; i
++)
6399 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
6401 while (nsource
> 0 || npad
> 0)
6403 /* Figure out which element to extract. */
6404 mpz_set_ui (index
, 0);
6406 for (i
= rank
- 1; i
>= 0; i
--)
6408 mpz_add_ui (index
, index
, x
[order
[i
]]);
6410 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
6413 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
6414 gfc_internal_error ("Reshaped array too large at %C");
6416 j
= mpz_get_ui (index
);
6419 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
6429 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
6433 gfc_constructor_append_expr (&result
->value
.constructor
,
6434 gfc_copy_expr (e
), &e
->where
);
6436 /* Calculate the next element. */
6440 if (++x
[i
] < shape
[i
])
6456 gfc_simplify_rrspacing (gfc_expr
*x
)
6462 if (x
->expr_type
!= EXPR_CONSTANT
)
6465 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
6467 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
6469 /* RRSPACING(+/- 0.0) = 0.0 */
6470 if (mpfr_zero_p (x
->value
.real
))
6472 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
6476 /* RRSPACING(inf) = NaN */
6477 if (mpfr_inf_p (x
->value
.real
))
6479 mpfr_set_nan (result
->value
.real
);
6483 /* RRSPACING(NaN) = same NaN */
6484 if (mpfr_nan_p (x
->value
.real
))
6486 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6490 /* | x * 2**(-e) | * 2**p. */
6491 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6492 e
= - (long int) mpfr_get_exp (x
->value
.real
);
6493 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
6495 p
= (long int) gfc_real_kinds
[i
].digits
;
6496 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
6498 return range_check (result
, "RRSPACING");
6503 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
6505 int k
, neg_flag
, power
, exp_range
;
6506 mpfr_t scale
, radix
;
6509 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
6512 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
6514 if (mpfr_zero_p (x
->value
.real
))
6516 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
6520 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
6522 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
6524 /* This check filters out values of i that would overflow an int. */
6525 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
6526 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
6528 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
6529 gfc_free_expr (result
);
6530 return &gfc_bad_expr
;
6533 /* Compute scale = radix ** power. */
6534 power
= mpz_get_si (i
->value
.integer
);
6544 gfc_set_model_kind (x
->ts
.kind
);
6547 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
6548 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
6551 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
6553 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
6555 mpfr_clears (scale
, radix
, NULL
);
6557 return range_check (result
, "SCALE");
6561 /* Variants of strspn and strcspn that operate on wide characters. */
6564 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
6567 const gfc_char_t
*c
;
6571 for (c
= s2
; *c
; c
++)
6585 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
6588 const gfc_char_t
*c
;
6592 for (c
= s2
; *c
; c
++)
6607 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
6612 size_t indx
, len
, lenc
;
6613 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
6616 return &gfc_bad_expr
;
6618 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
6619 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
6622 if (b
!= NULL
&& b
->value
.logical
!= 0)
6627 len
= e
->value
.character
.length
;
6628 lenc
= c
->value
.character
.length
;
6630 if (len
== 0 || lenc
== 0)
6638 indx
= wide_strcspn (e
->value
.character
.string
,
6639 c
->value
.character
.string
) + 1;
6646 for (indx
= len
; indx
> 0; indx
--)
6648 for (i
= 0; i
< lenc
; i
++)
6650 if (c
->value
.character
.string
[i
]
6651 == e
->value
.character
.string
[indx
- 1])
6660 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
6661 return range_check (result
, "SCAN");
6666 gfc_simplify_selected_char_kind (gfc_expr
*e
)
6670 if (e
->expr_type
!= EXPR_CONSTANT
)
6673 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
6674 || gfc_compare_with_Cstring (e
, "default", false) == 0)
6676 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
6681 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
6686 gfc_simplify_selected_int_kind (gfc_expr
*e
)
6690 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
))
6695 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
6696 if (gfc_integer_kinds
[i
].range
>= range
6697 && gfc_integer_kinds
[i
].kind
< kind
)
6698 kind
= gfc_integer_kinds
[i
].kind
;
6700 if (kind
== INT_MAX
)
6703 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
6708 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
6710 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
6712 locus
*loc
= &gfc_current_locus
;
6718 if (p
->expr_type
!= EXPR_CONSTANT
6719 || gfc_extract_int (p
, &precision
))
6728 if (q
->expr_type
!= EXPR_CONSTANT
6729 || gfc_extract_int (q
, &range
))
6740 if (rdx
->expr_type
!= EXPR_CONSTANT
6741 || gfc_extract_int (rdx
, &radix
))
6749 found_precision
= 0;
6753 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
6755 if (gfc_real_kinds
[i
].precision
>= precision
)
6756 found_precision
= 1;
6758 if (gfc_real_kinds
[i
].range
>= range
)
6761 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
6764 if (gfc_real_kinds
[i
].precision
>= precision
6765 && gfc_real_kinds
[i
].range
>= range
6766 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
6767 && gfc_real_kinds
[i
].kind
< kind
)
6768 kind
= gfc_real_kinds
[i
].kind
;
6771 if (kind
== INT_MAX
)
6773 if (found_radix
&& found_range
&& !found_precision
)
6775 else if (found_radix
&& found_precision
&& !found_range
)
6777 else if (found_radix
&& !found_precision
&& !found_range
)
6779 else if (found_radix
)
6785 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
6790 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
6793 mpfr_t exp
, absv
, log2
, pow2
, frac
;
6796 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
6799 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
6801 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
6802 SET_EXPONENT (NaN) = same NaN */
6803 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
6805 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6809 /* SET_EXPONENT (inf) = NaN */
6810 if (mpfr_inf_p (x
->value
.real
))
6812 mpfr_set_nan (result
->value
.real
);
6816 gfc_set_model_kind (x
->ts
.kind
);
6823 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
6824 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
6826 mpfr_trunc (log2
, log2
);
6827 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
6829 /* Old exponent value, and fraction. */
6830 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
6832 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
6835 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
6836 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
6838 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
6840 return range_check (result
, "SET_EXPONENT");
6845 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
6847 mpz_t shape
[GFC_MAX_DIMENSIONS
];
6848 gfc_expr
*result
, *e
, *f
;
6852 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
6854 if (source
->rank
== -1)
6857 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
6859 if (source
->rank
== 0)
6862 if (source
->expr_type
== EXPR_VARIABLE
)
6864 ar
= gfc_find_array_ref (source
);
6865 t
= gfc_array_ref_shape (ar
, shape
);
6867 else if (source
->shape
)
6870 for (n
= 0; n
< source
->rank
; n
++)
6872 mpz_init (shape
[n
]);
6873 mpz_set (shape
[n
], source
->shape
[n
]);
6879 for (n
= 0; n
< source
->rank
; n
++)
6881 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
6884 mpz_set (e
->value
.integer
, shape
[n
]);
6887 mpz_set_ui (e
->value
.integer
, n
+ 1);
6889 f
= simplify_size (source
, e
, k
);
6893 gfc_free_expr (result
);
6900 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
6902 gfc_free_expr (result
);
6904 gfc_clear_shape (shape
, source
->rank
);
6905 return &gfc_bad_expr
;
6908 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
6912 gfc_clear_shape (shape
, source
->rank
);
6919 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
6922 gfc_expr
*return_value
;
6925 /* For unary operations, the size of the result is given by the size
6926 of the operand. For binary ones, it's the size of the first operand
6927 unless it is scalar, then it is the size of the second. */
6928 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
6930 gfc_expr
* replacement
;
6931 gfc_expr
* simplified
;
6933 switch (array
->value
.op
.op
)
6935 /* Unary operations. */
6937 case INTRINSIC_UPLUS
:
6938 case INTRINSIC_UMINUS
:
6939 case INTRINSIC_PARENTHESES
:
6940 replacement
= array
->value
.op
.op1
;
6943 /* Binary operations. If any one of the operands is scalar, take
6944 the other one's size. If both of them are arrays, it does not
6945 matter -- try to find one with known shape, if possible. */
6947 if (array
->value
.op
.op1
->rank
== 0)
6948 replacement
= array
->value
.op
.op2
;
6949 else if (array
->value
.op
.op2
->rank
== 0)
6950 replacement
= array
->value
.op
.op1
;
6953 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
6957 replacement
= array
->value
.op
.op2
;
6962 /* Try to reduce it directly if possible. */
6963 simplified
= simplify_size (replacement
, dim
, k
);
6965 /* Otherwise, we build a new SIZE call. This is hopefully at least
6966 simpler than the original one. */
6969 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
6970 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
6971 GFC_ISYM_SIZE
, "size",
6973 gfc_copy_expr (replacement
),
6974 gfc_copy_expr (dim
),
6982 if (!gfc_array_size (array
, &size
))
6987 if (dim
->expr_type
!= EXPR_CONSTANT
)
6990 d
= mpz_get_ui (dim
->value
.integer
) - 1;
6991 if (!gfc_array_dimen_size (array
, d
, &size
))
6995 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
6996 mpz_set (return_value
->value
.integer
, size
);
6999 return return_value
;
7004 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
7007 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
7010 return &gfc_bad_expr
;
7012 result
= simplify_size (array
, dim
, k
);
7013 if (result
== NULL
|| result
== &gfc_bad_expr
)
7016 return range_check (result
, "SIZE");
7020 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
7021 multiplied by the array size. */
7024 gfc_simplify_sizeof (gfc_expr
*x
)
7026 gfc_expr
*result
= NULL
;
7029 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7032 if (x
->ts
.type
== BT_CHARACTER
7033 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7034 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7037 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
7038 && !gfc_array_size (x
, &array_size
))
7041 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
7043 mpz_set_si (result
->value
.integer
, gfc_target_expr_size (x
));
7049 /* STORAGE_SIZE returns the size in bits of a single array element. */
7052 gfc_simplify_storage_size (gfc_expr
*x
,
7055 gfc_expr
*result
= NULL
;
7058 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7061 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
7062 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7063 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7066 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
7068 return &gfc_bad_expr
;
7070 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
7072 mpz_set_si (result
->value
.integer
, gfc_element_size (x
));
7073 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
7075 return range_check (result
, "STORAGE_SIZE");
7080 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
7084 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
7087 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7092 mpz_abs (result
->value
.integer
, x
->value
.integer
);
7093 if (mpz_sgn (y
->value
.integer
) < 0)
7094 mpz_neg (result
->value
.integer
, result
->value
.integer
);
7099 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
7102 mpfr_setsign (result
->value
.real
, x
->value
.real
,
7103 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
7107 gfc_internal_error ("Bad type in gfc_simplify_sign");
7115 gfc_simplify_sin (gfc_expr
*x
)
7119 if (x
->expr_type
!= EXPR_CONSTANT
)
7122 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7127 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7131 gfc_set_model (x
->value
.real
);
7132 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7136 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
7139 return range_check (result
, "SIN");
7144 gfc_simplify_sinh (gfc_expr
*x
)
7148 if (x
->expr_type
!= EXPR_CONSTANT
)
7151 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7156 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7160 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7167 return range_check (result
, "SINH");
7171 /* The argument is always a double precision real that is converted to
7172 single precision. TODO: Rounding! */
7175 gfc_simplify_sngl (gfc_expr
*a
)
7179 if (a
->expr_type
!= EXPR_CONSTANT
)
7182 result
= gfc_real2real (a
, gfc_default_real_kind
);
7183 return range_check (result
, "SNGL");
7188 gfc_simplify_spacing (gfc_expr
*x
)
7194 if (x
->expr_type
!= EXPR_CONSTANT
)
7197 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7198 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7200 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
7201 if (mpfr_zero_p (x
->value
.real
))
7203 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
7207 /* SPACING(inf) = NaN */
7208 if (mpfr_inf_p (x
->value
.real
))
7210 mpfr_set_nan (result
->value
.real
);
7214 /* SPACING(NaN) = same NaN */
7215 if (mpfr_nan_p (x
->value
.real
))
7217 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7221 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
7222 are the radix, exponent of x, and precision. This excludes the
7223 possibility of subnormal numbers. Fortran 2003 states the result is
7224 b**max(e - p, emin - 1). */
7226 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
7227 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
7228 en
= en
> ep
? en
: ep
;
7230 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
7231 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
7233 return range_check (result
, "SPACING");
7238 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
7240 gfc_expr
*result
= NULL
;
7241 int nelem
, i
, j
, dim
, ncopies
;
7244 if ((!gfc_is_constant_expr (source
)
7245 && !is_constant_array_expr (source
))
7246 || !gfc_is_constant_expr (dim_expr
)
7247 || !gfc_is_constant_expr (ncopies_expr
))
7250 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
7251 gfc_extract_int (dim_expr
, &dim
);
7252 dim
-= 1; /* zero-base DIM */
7254 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
7255 gfc_extract_int (ncopies_expr
, &ncopies
);
7256 ncopies
= MAX (ncopies
, 0);
7258 /* Do not allow the array size to exceed the limit for an array
7260 if (source
->expr_type
== EXPR_ARRAY
)
7262 if (!gfc_array_size (source
, &size
))
7263 gfc_internal_error ("Failure getting length of a constant array.");
7266 mpz_init_set_ui (size
, 1);
7268 nelem
= mpz_get_si (size
) * ncopies
;
7269 if (nelem
> flag_max_array_constructor
)
7271 if (gfc_current_ns
->sym_root
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
7273 gfc_error ("The number of elements (%d) in the array constructor "
7274 "at %L requires an increase of the allowed %d upper "
7275 "limit. See %<-fmax-array-constructor%> option.",
7276 nelem
, &source
->where
, flag_max_array_constructor
);
7277 return &gfc_bad_expr
;
7283 if (source
->expr_type
== EXPR_CONSTANT
)
7285 gcc_assert (dim
== 0);
7287 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7289 if (source
->ts
.type
== BT_DERIVED
)
7290 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7292 result
->shape
= gfc_get_shape (result
->rank
);
7293 mpz_init_set_si (result
->shape
[0], ncopies
);
7295 for (i
= 0; i
< ncopies
; ++i
)
7296 gfc_constructor_append_expr (&result
->value
.constructor
,
7297 gfc_copy_expr (source
), NULL
);
7299 else if (source
->expr_type
== EXPR_ARRAY
)
7301 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
7302 gfc_constructor
*source_ctor
;
7304 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
7305 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
7307 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7309 if (source
->ts
.type
== BT_DERIVED
)
7310 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7311 result
->rank
= source
->rank
+ 1;
7312 result
->shape
= gfc_get_shape (result
->rank
);
7314 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
7317 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
7319 mpz_init_set_si (result
->shape
[i
], ncopies
);
7321 extent
[i
] = mpz_get_si (result
->shape
[i
]);
7322 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
7326 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
7327 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
7329 for (i
= 0; i
< ncopies
; ++i
)
7330 gfc_constructor_insert_expr (&result
->value
.constructor
,
7331 gfc_copy_expr (source_ctor
->expr
),
7332 NULL
, offset
+ i
* rstride
[dim
]);
7334 offset
+= (dim
== 0 ? ncopies
: 1);
7339 gfc_error ("Simplification of SPREAD at %C not yet implemented");
7340 return &gfc_bad_expr
;
7343 if (source
->ts
.type
== BT_CHARACTER
)
7344 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
7351 gfc_simplify_sqrt (gfc_expr
*e
)
7353 gfc_expr
*result
= NULL
;
7355 if (e
->expr_type
!= EXPR_CONSTANT
)
7361 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
7363 gfc_error ("Argument of SQRT at %L has a negative value",
7365 return &gfc_bad_expr
;
7367 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7368 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
7372 gfc_set_model (e
->value
.real
);
7374 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7375 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
7379 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
7382 return range_check (result
, "SQRT");
7387 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
7389 if (gfc_is_size_zero_array (array
))
7393 result
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
,
7395 switch (array
->ts
.type
)
7398 mpz_set_ui (result
->value
.integer
, 0);
7402 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
7406 mpc_set_ui (result
->value
.complex, 0, GFC_MPC_RND_MODE
);
7416 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
7421 gfc_simplify_cotan (gfc_expr
*x
)
7426 if (x
->expr_type
!= EXPR_CONSTANT
)
7429 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7434 mpfr_cot (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7438 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
7439 val
= &result
->value
.complex;
7440 mpc_init2 (swp
, mpfr_get_default_prec ());
7441 mpc_cos (swp
, x
->value
.complex, GFC_MPC_RND_MODE
);
7442 mpc_sin (*val
, x
->value
.complex, GFC_MPC_RND_MODE
);
7443 mpc_div (*val
, swp
, *val
, GFC_MPC_RND_MODE
);
7451 return range_check (result
, "COTAN");
7456 gfc_simplify_tan (gfc_expr
*x
)
7460 if (x
->expr_type
!= EXPR_CONSTANT
)
7463 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7468 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7472 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7479 return range_check (result
, "TAN");
7484 gfc_simplify_tanh (gfc_expr
*x
)
7488 if (x
->expr_type
!= EXPR_CONSTANT
)
7491 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7496 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7500 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7507 return range_check (result
, "TANH");
7512 gfc_simplify_tiny (gfc_expr
*e
)
7517 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
7519 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
7520 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
7527 gfc_simplify_trailz (gfc_expr
*e
)
7529 unsigned long tz
, bs
;
7532 if (e
->expr_type
!= EXPR_CONSTANT
)
7535 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
7536 bs
= gfc_integer_kinds
[i
].bit_size
;
7537 tz
= mpz_scan1 (e
->value
.integer
, 0);
7539 return gfc_get_int_expr (gfc_default_integer_kind
,
7540 &e
->where
, MIN (tz
, bs
));
7545 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
7548 gfc_expr
*mold_element
;
7553 unsigned char *buffer
;
7554 size_t result_length
;
7556 if (!gfc_is_constant_expr (source
) || !gfc_is_constant_expr (size
))
7559 if (!gfc_resolve_expr (mold
))
7561 if (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
7564 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
7565 &result_size
, &result_length
))
7568 /* Calculate the size of the source. */
7569 if (source
->expr_type
== EXPR_ARRAY
&& !gfc_array_size (source
, &tmp
))
7570 gfc_internal_error ("Failure getting length of a constant array.");
7572 /* Create an empty new expression with the appropriate characteristics. */
7573 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
7575 result
->ts
= mold
->ts
;
7577 mold_element
= (mold
->expr_type
== EXPR_ARRAY
&& mold
->value
.constructor
)
7578 ? gfc_constructor_first (mold
->value
.constructor
)->expr
7581 /* Set result character length, if needed. Note that this needs to be
7582 set even for array expressions, in order to pass this information into
7583 gfc_target_interpret_expr. */
7584 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
7585 result
->value
.character
.length
= mold_element
->value
.character
.length
;
7587 /* Set the number of elements in the result, and determine its size. */
7589 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
7591 result
->expr_type
= EXPR_ARRAY
;
7593 result
->shape
= gfc_get_shape (1);
7594 mpz_init_set_ui (result
->shape
[0], result_length
);
7599 /* Allocate the buffer to store the binary version of the source. */
7600 buffer_size
= MAX (source_size
, result_size
);
7601 buffer
= (unsigned char*)alloca (buffer_size
);
7602 memset (buffer
, 0, buffer_size
);
7604 /* Now write source to the buffer. */
7605 gfc_target_encode_expr (source
, buffer
, buffer_size
);
7607 /* And read the buffer back into the new expression. */
7608 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
7615 gfc_simplify_transpose (gfc_expr
*matrix
)
7617 int row
, matrix_rows
, col
, matrix_cols
;
7620 if (!is_constant_array_expr (matrix
))
7623 gcc_assert (matrix
->rank
== 2);
7625 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
7628 result
->shape
= gfc_get_shape (result
->rank
);
7629 mpz_set (result
->shape
[0], matrix
->shape
[1]);
7630 mpz_set (result
->shape
[1], matrix
->shape
[0]);
7632 if (matrix
->ts
.type
== BT_CHARACTER
)
7633 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
7634 else if (matrix
->ts
.type
== BT_DERIVED
)
7635 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
7637 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
7638 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
7639 for (row
= 0; row
< matrix_rows
; ++row
)
7640 for (col
= 0; col
< matrix_cols
; ++col
)
7642 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
7643 col
* matrix_rows
+ row
);
7644 gfc_constructor_insert_expr (&result
->value
.constructor
,
7645 gfc_copy_expr (e
), &matrix
->where
,
7646 row
* matrix_cols
+ col
);
7654 gfc_simplify_trim (gfc_expr
*e
)
7657 int count
, i
, len
, lentrim
;
7659 if (e
->expr_type
!= EXPR_CONSTANT
)
7662 len
= e
->value
.character
.length
;
7663 for (count
= 0, i
= 1; i
<= len
; ++i
)
7665 if (e
->value
.character
.string
[len
- i
] == ' ')
7671 lentrim
= len
- count
;
7673 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
7674 for (i
= 0; i
< lentrim
; i
++)
7675 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
7682 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
7687 gfc_constructor
*sub_cons
;
7691 if (!is_constant_array_expr (sub
))
7694 /* Follow any component references. */
7695 as
= coarray
->symtree
->n
.sym
->as
;
7696 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
7697 if (ref
->type
== REF_COMPONENT
)
7700 if (as
->type
== AS_DEFERRED
)
7703 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
7704 the cosubscript addresses the first image. */
7706 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
7709 for (d
= 1; d
<= as
->corank
; d
++)
7714 gcc_assert (sub_cons
!= NULL
);
7716 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
7718 if (ca_bound
== NULL
)
7721 if (ca_bound
== &gfc_bad_expr
)
7724 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
7728 gfc_free_expr (ca_bound
);
7729 sub_cons
= gfc_constructor_next (sub_cons
);
7733 first_image
= false;
7737 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
7738 "SUB has %ld and COARRAY lower bound is %ld)",
7740 mpz_get_si (sub_cons
->expr
->value
.integer
),
7741 mpz_get_si (ca_bound
->value
.integer
));
7742 gfc_free_expr (ca_bound
);
7743 return &gfc_bad_expr
;
7746 gfc_free_expr (ca_bound
);
7748 /* Check whether upperbound is valid for the multi-images case. */
7751 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
7753 if (ca_bound
== &gfc_bad_expr
)
7756 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
7757 && mpz_cmp (ca_bound
->value
.integer
,
7758 sub_cons
->expr
->value
.integer
) < 0)
7760 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
7761 "SUB has %ld and COARRAY upper bound is %ld)",
7763 mpz_get_si (sub_cons
->expr
->value
.integer
),
7764 mpz_get_si (ca_bound
->value
.integer
));
7765 gfc_free_expr (ca_bound
);
7766 return &gfc_bad_expr
;
7770 gfc_free_expr (ca_bound
);
7773 sub_cons
= gfc_constructor_next (sub_cons
);
7776 gcc_assert (sub_cons
== NULL
);
7778 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
7781 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
7782 &gfc_current_locus
);
7784 mpz_set_si (result
->value
.integer
, 1);
7786 mpz_set_si (result
->value
.integer
, 0);
7792 gfc_simplify_image_status (gfc_expr
*image
, gfc_expr
*team ATTRIBUTE_UNUSED
)
7794 if (flag_coarray
== GFC_FCOARRAY_NONE
)
7796 gfc_current_locus
= *gfc_current_intrinsic_where
;
7797 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
7798 return &gfc_bad_expr
;
7801 /* Simplification is possible for fcoarray = single only. For all other modes
7802 the result depends on runtime conditions. */
7803 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
7806 if (gfc_is_constant_expr (image
))
7809 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
7811 if (mpz_get_si (image
->value
.integer
) == 1)
7812 mpz_set_si (result
->value
.integer
, 0);
7814 mpz_set_si (result
->value
.integer
, GFC_STAT_STOPPED_IMAGE
);
7823 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
7824 gfc_expr
*distance ATTRIBUTE_UNUSED
)
7826 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
7829 /* If no coarray argument has been passed or when the first argument
7830 is actually a distance argment. */
7831 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
7834 /* FIXME: gfc_current_locus is wrong. */
7835 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
7836 &gfc_current_locus
);
7837 mpz_set_si (result
->value
.integer
, 1);
7841 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
7842 return simplify_cobound (coarray
, dim
, NULL
, 0);
7847 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
7849 return simplify_bound (array
, dim
, kind
, 1);
7853 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
7855 return simplify_cobound (array
, dim
, kind
, 1);
7860 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
7862 gfc_expr
*result
, *e
;
7863 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
7865 if (!is_constant_array_expr (vector
)
7866 || !is_constant_array_expr (mask
)
7867 || (!gfc_is_constant_expr (field
)
7868 && !is_constant_array_expr (field
)))
7871 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
7873 if (vector
->ts
.type
== BT_DERIVED
)
7874 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
7875 result
->rank
= mask
->rank
;
7876 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
7878 if (vector
->ts
.type
== BT_CHARACTER
)
7879 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
7881 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
7882 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
7884 = field
->expr_type
== EXPR_ARRAY
7885 ? gfc_constructor_first (field
->value
.constructor
)
7890 if (mask_ctor
->expr
->value
.logical
)
7892 gcc_assert (vector_ctor
);
7893 e
= gfc_copy_expr (vector_ctor
->expr
);
7894 vector_ctor
= gfc_constructor_next (vector_ctor
);
7896 else if (field
->expr_type
== EXPR_ARRAY
)
7897 e
= gfc_copy_expr (field_ctor
->expr
);
7899 e
= gfc_copy_expr (field
);
7901 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
7903 mask_ctor
= gfc_constructor_next (mask_ctor
);
7904 field_ctor
= gfc_constructor_next (field_ctor
);
7912 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
7916 size_t index
, len
, lenset
;
7918 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
7921 return &gfc_bad_expr
;
7923 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
7924 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
7927 if (b
!= NULL
&& b
->value
.logical
!= 0)
7932 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
7934 len
= s
->value
.character
.length
;
7935 lenset
= set
->value
.character
.length
;
7939 mpz_set_ui (result
->value
.integer
, 0);
7947 mpz_set_ui (result
->value
.integer
, 1);
7951 index
= wide_strspn (s
->value
.character
.string
,
7952 set
->value
.character
.string
) + 1;
7961 mpz_set_ui (result
->value
.integer
, len
);
7964 for (index
= len
; index
> 0; index
--)
7966 for (i
= 0; i
< lenset
; i
++)
7968 if (s
->value
.character
.string
[index
- 1]
7969 == set
->value
.character
.string
[i
])
7977 mpz_set_ui (result
->value
.integer
, index
);
7983 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
7988 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
7991 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
7996 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
7997 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
7998 return range_check (result
, "XOR");
8001 return gfc_get_logical_expr (kind
, &x
->where
,
8002 (x
->value
.logical
&& !y
->value
.logical
)
8003 || (!x
->value
.logical
&& y
->value
.logical
));
8011 /****************** Constant simplification *****************/
8013 /* Master function to convert one constant to another. While this is
8014 used as a simplification function, it requires the destination type
8015 and kind information which is supplied by a special case in
8019 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
8021 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
8036 f
= gfc_int2complex
;
8056 f
= gfc_real2complex
;
8067 f
= gfc_complex2int
;
8070 f
= gfc_complex2real
;
8073 f
= gfc_complex2complex
;
8099 f
= gfc_hollerith2int
;
8103 f
= gfc_hollerith2real
;
8107 f
= gfc_hollerith2complex
;
8111 f
= gfc_hollerith2character
;
8115 f
= gfc_hollerith2logical
;
8124 if (type
== BT_CHARACTER
)
8125 f
= gfc_character2character
;
8132 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
8137 switch (e
->expr_type
)
8140 result
= f (e
, kind
);
8142 return &gfc_bad_expr
;
8146 if (!gfc_is_constant_expr (e
))
8149 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8150 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8151 result
->rank
= e
->rank
;
8153 for (c
= gfc_constructor_first (e
->value
.constructor
);
8154 c
; c
= gfc_constructor_next (c
))
8157 if (c
->iterator
== NULL
)
8158 tmp
= f (c
->expr
, kind
);
8161 g
= gfc_convert_constant (c
->expr
, type
, kind
);
8162 if (g
== &gfc_bad_expr
)
8164 gfc_free_expr (result
);
8172 gfc_free_expr (result
);
8176 gfc_constructor_append_expr (&result
->value
.constructor
,
8190 /* Function for converting character constants. */
8192 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
8197 if (!gfc_is_constant_expr (e
))
8200 if (e
->expr_type
== EXPR_CONSTANT
)
8202 /* Simple case of a scalar. */
8203 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
8205 return &gfc_bad_expr
;
8207 result
->value
.character
.length
= e
->value
.character
.length
;
8208 result
->value
.character
.string
8209 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
8210 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
8211 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
8213 /* Check we only have values representable in the destination kind. */
8214 for (i
= 0; i
< result
->value
.character
.length
; i
++)
8215 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
8218 gfc_error ("Character %qs in string at %L cannot be converted "
8219 "into character kind %d",
8220 gfc_print_wide_char (result
->value
.character
.string
[i
]),
8222 gfc_free_expr (result
);
8223 return &gfc_bad_expr
;
8228 else if (e
->expr_type
== EXPR_ARRAY
)
8230 /* For an array constructor, we convert each constructor element. */
8233 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8234 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8235 result
->rank
= e
->rank
;
8236 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
8238 for (c
= gfc_constructor_first (e
->value
.constructor
);
8239 c
; c
= gfc_constructor_next (c
))
8241 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
8242 if (tmp
== &gfc_bad_expr
)
8244 gfc_free_expr (result
);
8245 return &gfc_bad_expr
;
8250 gfc_free_expr (result
);
8254 gfc_constructor_append_expr (&result
->value
.constructor
,
8266 gfc_simplify_compiler_options (void)
8271 str
= gfc_get_option_string ();
8272 result
= gfc_get_character_expr (gfc_default_character_kind
,
8273 &gfc_current_locus
, str
, strlen (str
));
8280 gfc_simplify_compiler_version (void)
8285 len
= strlen ("GCC version ") + strlen (version_string
);
8286 buffer
= XALLOCAVEC (char, len
+ 1);
8287 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
8288 return gfc_get_character_expr (gfc_default_character_kind
,
8289 &gfc_current_locus
, buffer
, len
);
8292 /* Simplification routines for intrinsics of IEEE modules. */
8295 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
8297 gfc_actual_arglist
*arg
;
8298 gfc_expr
*p
= NULL
, *q
= NULL
, *rdx
= NULL
;
8300 arg
= expr
->value
.function
.actual
;
8304 q
= arg
->next
->expr
;
8305 if (arg
->next
->next
)
8306 rdx
= arg
->next
->next
->expr
;
8309 /* Currently, if IEEE is supported and this module is built, it means
8310 all our floating-point types conform to IEEE. Hence, we simply handle
8311 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
8312 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
8316 simplify_ieee_support (gfc_expr
*expr
)
8318 /* We consider that if the IEEE modules are loaded, we have full support
8319 for flags, halting and rounding, which are the three functions
8320 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
8321 expressions. One day, we will need libgfortran to detect support and
8322 communicate it back to us, allowing for partial support. */
8324 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
8329 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
8331 int n
= strlen(name
);
8333 if (!strncmp(sym
->name
, name
, n
))
8336 /* If a generic was used and renamed, we need more work to find out.
8337 Compare the specific name. */
8338 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
8345 gfc_simplify_ieee_functions (gfc_expr
*expr
)
8347 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
8349 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
8350 return simplify_ieee_selected_real_kind (expr
);
8351 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
8352 || matches_ieee_function_name(sym
, "ieee_support_halting")
8353 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
8354 return simplify_ieee_support (expr
);