1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2014 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"
27 #include "intrinsic.h"
28 #include "target-memory.h"
29 #include "constructor.h"
30 #include "tm.h" /* For BITS_PER_UNIT. */
31 #include "version.h" /* For version_string. */
34 gfc_expr gfc_bad_expr
;
36 static gfc_expr
*simplify_size (gfc_expr
*, gfc_expr
*, int);
39 /* Note that 'simplification' is not just transforming expressions.
40 For functions that are not simplified at compile time, range
41 checking is done if possible.
43 The return convention is that each simplification function returns:
45 A new expression node corresponding to the simplified arguments.
46 The original arguments are destroyed by the caller, and must not
47 be a part of the new expression.
49 NULL pointer indicating that no simplification was possible and
50 the original expression should remain intact.
52 An expression pointer to gfc_bad_expr (a static placeholder)
53 indicating that some error has prevented simplification. The
54 error is generated within the function and should be propagated
57 By the time a simplification function gets control, it has been
58 decided that the function call is really supposed to be the
59 intrinsic. No type checking is strictly necessary, since only
60 valid types will be passed on. On the other hand, a simplification
61 subroutine may have to look at the type of an argument as part of
64 Array arguments are only passed to these subroutines that implement
65 the simplification of transformational intrinsics.
67 The functions in this file don't have much comment with them, but
68 everything is reasonably straight-forward. The Standard, chapter 13
69 is the best comment you'll find for this file anyway. */
71 /* Range checks an expression node. If all goes well, returns the
72 node, otherwise returns &gfc_bad_expr and frees the node. */
75 range_check (gfc_expr
*result
, const char *name
)
80 if (result
->expr_type
!= EXPR_CONSTANT
)
83 switch (gfc_range_check (result
))
89 gfc_error ("Result of %s overflows its kind at %L", name
,
94 gfc_error ("Result of %s underflows its kind at %L", name
,
99 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
103 gfc_error ("Result of %s gives range error for its kind at %L", name
,
108 gfc_free_expr (result
);
109 return &gfc_bad_expr
;
113 /* A helper function that gets an optional and possibly missing
114 kind parameter. Returns the kind, -1 if something went wrong. */
117 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
124 if (k
->expr_type
!= EXPR_CONSTANT
)
126 gfc_error ("KIND parameter of %s at %L must be an initialization "
127 "expression", name
, &k
->where
);
131 if (gfc_extract_int (k
, &kind
) != NULL
132 || gfc_validate_kind (type
, kind
, true) < 0)
134 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
142 /* Converts an mpz_t signed variable into an unsigned one, assuming
143 two's complement representations and a binary width of bitsize.
144 The conversion is a no-op unless x is negative; otherwise, it can
145 be accomplished by masking out the high bits. */
148 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
154 /* Confirm that no bits above the signed range are unset if we
155 are doing range checking. */
156 if (gfc_option
.flag_range_check
!= 0)
157 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
159 mpz_init_set_ui (mask
, 1);
160 mpz_mul_2exp (mask
, mask
, bitsize
);
161 mpz_sub_ui (mask
, mask
, 1);
163 mpz_and (x
, x
, mask
);
169 /* Confirm that no bits above the signed range are set. */
170 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
175 /* Converts an mpz_t unsigned variable into a signed one, assuming
176 two's complement representations and a binary width of bitsize.
177 If the bitsize-1 bit is set, this is taken as a sign bit and
178 the number is converted to the corresponding negative number. */
181 gfc_convert_mpz_to_signed (mpz_t x
, int bitsize
)
185 /* Confirm that no bits above the unsigned range are set if we are
186 doing range checking. */
187 if (gfc_option
.flag_range_check
!= 0)
188 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
190 if (mpz_tstbit (x
, bitsize
- 1) == 1)
192 mpz_init_set_ui (mask
, 1);
193 mpz_mul_2exp (mask
, mask
, bitsize
);
194 mpz_sub_ui (mask
, mask
, 1);
196 /* We negate the number by hand, zeroing the high bits, that is
197 make it the corresponding positive number, and then have it
198 negated by GMP, giving the correct representation of the
201 mpz_add_ui (x
, x
, 1);
202 mpz_and (x
, x
, mask
);
211 /* In-place convert BOZ to REAL of the specified kind. */
214 convert_boz (gfc_expr
*x
, int kind
)
216 if (x
&& x
->ts
.type
== BT_INTEGER
&& x
->is_boz
)
223 if (!gfc_convert_boz (x
, &ts
))
224 return &gfc_bad_expr
;
231 /* Test that the expression is an constant array. */
234 is_constant_array_expr (gfc_expr
*e
)
241 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
244 for (c
= gfc_constructor_first (e
->value
.constructor
);
245 c
; c
= gfc_constructor_next (c
))
246 if (c
->expr
->expr_type
!= EXPR_CONSTANT
247 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
254 /* Initialize a transformational result expression with a given value. */
257 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
259 if (e
&& e
->expr_type
== EXPR_ARRAY
)
261 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
264 init_result_expr (ctor
->expr
, init
, array
);
265 ctor
= gfc_constructor_next (ctor
);
268 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
270 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
277 e
->value
.logical
= (init
? 1 : 0);
282 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
283 else if (init
== INT_MAX
)
284 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
286 mpz_set_si (e
->value
.integer
, init
);
292 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
293 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
295 else if (init
== INT_MAX
)
296 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
298 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
302 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
308 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
309 gfc_extract_int (len
, &length
);
310 string
= gfc_get_wide_string (length
+ 1);
311 gfc_wide_memset (string
, 0, length
);
313 else if (init
== INT_MAX
)
315 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
316 gfc_extract_int (len
, &length
);
317 string
= gfc_get_wide_string (length
+ 1);
318 gfc_wide_memset (string
, 255, length
);
323 string
= gfc_get_wide_string (1);
326 string
[length
] = '\0';
327 e
->value
.character
.length
= length
;
328 e
->value
.character
.string
= string
;
340 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
341 if conj_a is true, the matrix_a is complex conjugated. */
344 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
345 gfc_expr
*matrix_b
, int stride_b
, int offset_b
,
348 gfc_expr
*result
, *a
, *b
, *c
;
350 result
= gfc_get_constant_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
352 init_result_expr (result
, 0, NULL
);
354 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
355 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
358 /* Copying of expressions is required as operands are free'd
359 by the gfc_arith routines. */
360 switch (result
->ts
.type
)
363 result
= gfc_or (result
,
364 gfc_and (gfc_copy_expr (a
),
371 if (conj_a
&& a
->ts
.type
== BT_COMPLEX
)
372 c
= gfc_simplify_conjg (a
);
374 c
= gfc_copy_expr (a
);
375 result
= gfc_add (result
, gfc_multiply (c
, gfc_copy_expr (b
)));
382 offset_a
+= stride_a
;
383 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
385 offset_b
+= stride_b
;
386 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
393 /* Build a result expression for transformational intrinsics,
397 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
398 int kind
, locus
* where
)
403 if (!dim
|| array
->rank
== 1)
404 return gfc_get_constant_expr (type
, kind
, where
);
406 result
= gfc_get_array_expr (type
, kind
, where
);
407 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
408 result
->rank
= array
->rank
- 1;
410 /* gfc_array_size() would count the number of elements in the constructor,
411 we have not built those yet. */
413 for (i
= 0; i
< result
->rank
; ++i
)
414 nelem
*= mpz_get_ui (result
->shape
[i
]);
416 for (i
= 0; i
< nelem
; ++i
)
418 gfc_constructor_append_expr (&result
->value
.constructor
,
419 gfc_get_constant_expr (type
, kind
, where
),
427 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
429 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
430 of COUNT intrinsic is .TRUE..
432 Interface and implementation mimics arith functions as
433 gfc_add, gfc_multiply, etc. */
435 static gfc_expr
* gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
439 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
440 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
441 gcc_assert (op2
->value
.logical
);
443 result
= gfc_copy_expr (op1
);
444 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
452 /* Transforms an ARRAY with operation OP, according to MASK, to a
453 scalar RESULT. E.g. called if
455 REAL, PARAMETER :: array(n, m) = ...
456 REAL, PARAMETER :: s = SUM(array)
458 where OP == gfc_add(). */
461 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
462 transformational_op op
)
465 gfc_constructor
*array_ctor
, *mask_ctor
;
467 /* Shortcut for constant .FALSE. MASK. */
469 && mask
->expr_type
== EXPR_CONSTANT
470 && !mask
->value
.logical
)
473 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
475 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
476 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
480 a
= array_ctor
->expr
;
481 array_ctor
= gfc_constructor_next (array_ctor
);
483 /* A constant MASK equals .TRUE. here and can be ignored. */
487 mask_ctor
= gfc_constructor_next (mask_ctor
);
488 if (!m
->value
.logical
)
492 result
= op (result
, gfc_copy_expr (a
));
498 /* Transforms an ARRAY with operation OP, according to MASK, to an
499 array RESULT. E.g. called if
501 REAL, PARAMETER :: array(n, m) = ...
502 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
504 where OP == gfc_multiply().
505 The result might be post processed using post_op. */
508 simplify_transformation_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*dim
,
509 gfc_expr
*mask
, transformational_op op
,
510 transformational_op post_op
)
513 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
514 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
515 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
517 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
518 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
519 tmpstride
[GFC_MAX_DIMENSIONS
];
521 /* Shortcut for constant .FALSE. MASK. */
523 && mask
->expr_type
== EXPR_CONSTANT
524 && !mask
->value
.logical
)
527 /* Build an indexed table for array element expressions to minimize
528 linked-list traversal. Masked elements are set to NULL. */
529 gfc_array_size (array
, &size
);
530 arraysize
= mpz_get_ui (size
);
533 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
535 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
537 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
538 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
540 for (i
= 0; i
< arraysize
; ++i
)
542 arrayvec
[i
] = array_ctor
->expr
;
543 array_ctor
= gfc_constructor_next (array_ctor
);
547 if (!mask_ctor
->expr
->value
.logical
)
550 mask_ctor
= gfc_constructor_next (mask_ctor
);
554 /* Same for the result expression. */
555 gfc_array_size (result
, &size
);
556 resultsize
= mpz_get_ui (size
);
559 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
560 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
561 for (i
= 0; i
< resultsize
; ++i
)
563 resultvec
[i
] = result_ctor
->expr
;
564 result_ctor
= gfc_constructor_next (result_ctor
);
567 gfc_extract_int (dim
, &dim_index
);
568 dim_index
-= 1; /* zero-base index */
572 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
575 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
578 dim_extent
= mpz_get_si (array
->shape
[i
]);
579 dim_stride
= tmpstride
[i
];
583 extent
[n
] = mpz_get_si (array
->shape
[i
]);
584 sstride
[n
] = tmpstride
[i
];
585 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
594 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
596 *dest
= op (*dest
, gfc_copy_expr (*src
));
603 while (!done
&& count
[n
] == extent
[n
])
606 base
-= sstride
[n
] * extent
[n
];
607 dest
-= dstride
[n
] * extent
[n
];
610 if (n
< result
->rank
)
621 /* Place updated expression in result constructor. */
622 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
623 for (i
= 0; i
< resultsize
; ++i
)
626 result_ctor
->expr
= post_op (result_ctor
->expr
, resultvec
[i
]);
628 result_ctor
->expr
= resultvec
[i
];
629 result_ctor
= gfc_constructor_next (result_ctor
);
639 simplify_transformation (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
640 int init_val
, transformational_op op
)
644 if (!is_constant_array_expr (array
)
645 || !gfc_is_constant_expr (dim
))
649 && !is_constant_array_expr (mask
)
650 && mask
->expr_type
!= EXPR_CONSTANT
)
653 result
= transformational_result (array
, dim
, array
->ts
.type
,
654 array
->ts
.kind
, &array
->where
);
655 init_result_expr (result
, init_val
, NULL
);
657 return !dim
|| array
->rank
== 1 ?
658 simplify_transformation_to_scalar (result
, array
, mask
, op
) :
659 simplify_transformation_to_array (result
, array
, dim
, mask
, op
, NULL
);
663 /********************** Simplification functions *****************************/
666 gfc_simplify_abs (gfc_expr
*e
)
670 if (e
->expr_type
!= EXPR_CONSTANT
)
676 result
= gfc_get_constant_expr (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
677 mpz_abs (result
->value
.integer
, e
->value
.integer
);
678 return range_check (result
, "IABS");
681 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
682 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
683 return range_check (result
, "ABS");
686 gfc_set_model_kind (e
->ts
.kind
);
687 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
688 mpc_abs (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
689 return range_check (result
, "CABS");
692 gfc_internal_error ("gfc_simplify_abs(): Bad type");
698 simplify_achar_char (gfc_expr
*e
, gfc_expr
*k
, const char *name
, bool ascii
)
702 bool too_large
= false;
704 if (e
->expr_type
!= EXPR_CONSTANT
)
707 kind
= get_kind (BT_CHARACTER
, k
, name
, gfc_default_character_kind
);
709 return &gfc_bad_expr
;
711 if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
713 gfc_error ("Argument of %s function at %L is negative", name
,
715 return &gfc_bad_expr
;
718 if (ascii
&& gfc_option
.warn_surprising
719 && mpz_cmp_si (e
->value
.integer
, 127) > 0)
720 gfc_warning ("Argument of %s function at %L outside of range [0,127]",
723 if (kind
== 1 && mpz_cmp_si (e
->value
.integer
, 255) > 0)
728 mpz_init_set_ui (t
, 2);
729 mpz_pow_ui (t
, t
, 32);
730 mpz_sub_ui (t
, t
, 1);
731 if (mpz_cmp (e
->value
.integer
, t
) > 0)
738 gfc_error ("Argument of %s function at %L is too large for the "
739 "collating sequence of kind %d", name
, &e
->where
, kind
);
740 return &gfc_bad_expr
;
743 result
= gfc_get_character_expr (kind
, &e
->where
, NULL
, 1);
744 result
->value
.character
.string
[0] = mpz_get_ui (e
->value
.integer
);
751 /* We use the processor's collating sequence, because all
752 systems that gfortran currently works on are ASCII. */
755 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
757 return simplify_achar_char (e
, k
, "ACHAR", true);
762 gfc_simplify_acos (gfc_expr
*x
)
766 if (x
->expr_type
!= EXPR_CONSTANT
)
772 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
773 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
775 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
777 return &gfc_bad_expr
;
779 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
780 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
784 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
785 mpc_acos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
789 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
792 return range_check (result
, "ACOS");
796 gfc_simplify_acosh (gfc_expr
*x
)
800 if (x
->expr_type
!= EXPR_CONSTANT
)
806 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
808 gfc_error ("Argument of ACOSH at %L must not be less than 1",
810 return &gfc_bad_expr
;
813 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
814 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
818 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
819 mpc_acosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
823 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
826 return range_check (result
, "ACOSH");
830 gfc_simplify_adjustl (gfc_expr
*e
)
836 if (e
->expr_type
!= EXPR_CONSTANT
)
839 len
= e
->value
.character
.length
;
841 for (count
= 0, i
= 0; i
< len
; ++i
)
843 ch
= e
->value
.character
.string
[i
];
849 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
850 for (i
= 0; i
< len
- count
; ++i
)
851 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
858 gfc_simplify_adjustr (gfc_expr
*e
)
864 if (e
->expr_type
!= EXPR_CONSTANT
)
867 len
= e
->value
.character
.length
;
869 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
871 ch
= e
->value
.character
.string
[i
];
877 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
878 for (i
= 0; i
< count
; ++i
)
879 result
->value
.character
.string
[i
] = ' ';
881 for (i
= count
; i
< len
; ++i
)
882 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
889 gfc_simplify_aimag (gfc_expr
*e
)
893 if (e
->expr_type
!= EXPR_CONSTANT
)
896 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
897 mpfr_set (result
->value
.real
, mpc_imagref (e
->value
.complex), GFC_RND_MODE
);
899 return range_check (result
, "AIMAG");
904 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
906 gfc_expr
*rtrunc
, *result
;
909 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
911 return &gfc_bad_expr
;
913 if (e
->expr_type
!= EXPR_CONSTANT
)
916 rtrunc
= gfc_copy_expr (e
);
917 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
919 result
= gfc_real2real (rtrunc
, kind
);
921 gfc_free_expr (rtrunc
);
923 return range_check (result
, "AINT");
928 gfc_simplify_all (gfc_expr
*mask
, gfc_expr
*dim
)
930 return simplify_transformation (mask
, dim
, NULL
, true, gfc_and
);
935 gfc_simplify_dint (gfc_expr
*e
)
937 gfc_expr
*rtrunc
, *result
;
939 if (e
->expr_type
!= EXPR_CONSTANT
)
942 rtrunc
= gfc_copy_expr (e
);
943 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
945 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
947 gfc_free_expr (rtrunc
);
949 return range_check (result
, "DINT");
954 gfc_simplify_dreal (gfc_expr
*e
)
956 gfc_expr
*result
= NULL
;
958 if (e
->expr_type
!= EXPR_CONSTANT
)
961 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
962 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
964 return range_check (result
, "DREAL");
969 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
974 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
976 return &gfc_bad_expr
;
978 if (e
->expr_type
!= EXPR_CONSTANT
)
981 result
= gfc_get_constant_expr (e
->ts
.type
, kind
, &e
->where
);
982 mpfr_round (result
->value
.real
, e
->value
.real
);
984 return range_check (result
, "ANINT");
989 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
994 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
997 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1002 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
1003 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1004 return range_check (result
, "AND");
1007 return gfc_get_logical_expr (kind
, &x
->where
,
1008 x
->value
.logical
&& y
->value
.logical
);
1017 gfc_simplify_any (gfc_expr
*mask
, gfc_expr
*dim
)
1019 return simplify_transformation (mask
, dim
, NULL
, false, gfc_or
);
1024 gfc_simplify_dnint (gfc_expr
*e
)
1028 if (e
->expr_type
!= EXPR_CONSTANT
)
1031 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &e
->where
);
1032 mpfr_round (result
->value
.real
, e
->value
.real
);
1034 return range_check (result
, "DNINT");
1039 gfc_simplify_asin (gfc_expr
*x
)
1043 if (x
->expr_type
!= EXPR_CONSTANT
)
1049 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1050 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1052 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1054 return &gfc_bad_expr
;
1056 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1057 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1061 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1062 mpc_asin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1066 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1069 return range_check (result
, "ASIN");
1074 gfc_simplify_asinh (gfc_expr
*x
)
1078 if (x
->expr_type
!= EXPR_CONSTANT
)
1081 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1086 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1090 mpc_asinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1094 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1097 return range_check (result
, "ASINH");
1102 gfc_simplify_atan (gfc_expr
*x
)
1106 if (x
->expr_type
!= EXPR_CONSTANT
)
1109 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1114 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1118 mpc_atan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1122 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1125 return range_check (result
, "ATAN");
1130 gfc_simplify_atanh (gfc_expr
*x
)
1134 if (x
->expr_type
!= EXPR_CONSTANT
)
1140 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
1141 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
1143 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1145 return &gfc_bad_expr
;
1147 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1148 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1152 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1153 mpc_atanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1157 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1160 return range_check (result
, "ATANH");
1165 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1169 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1172 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1174 gfc_error ("If first argument of ATAN2 %L is zero, then the "
1175 "second argument must not be zero", &x
->where
);
1176 return &gfc_bad_expr
;
1179 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1180 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1182 return range_check (result
, "ATAN2");
1187 gfc_simplify_bessel_j0 (gfc_expr
*x
)
1191 if (x
->expr_type
!= EXPR_CONSTANT
)
1194 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1195 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1197 return range_check (result
, "BESSEL_J0");
1202 gfc_simplify_bessel_j1 (gfc_expr
*x
)
1206 if (x
->expr_type
!= EXPR_CONSTANT
)
1209 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1210 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1212 return range_check (result
, "BESSEL_J1");
1217 gfc_simplify_bessel_jn (gfc_expr
*order
, gfc_expr
*x
)
1222 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1225 n
= mpz_get_si (order
->value
.integer
);
1226 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1227 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1229 return range_check (result
, "BESSEL_JN");
1233 /* Simplify transformational form of JN and YN. */
1236 gfc_simplify_bessel_n2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
,
1243 mpfr_t x2rev
, last1
, last2
;
1245 if (x
->expr_type
!= EXPR_CONSTANT
|| order1
->expr_type
!= EXPR_CONSTANT
1246 || order2
->expr_type
!= EXPR_CONSTANT
)
1249 n1
= mpz_get_si (order1
->value
.integer
);
1250 n2
= mpz_get_si (order2
->value
.integer
);
1251 result
= gfc_get_array_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1253 result
->shape
= gfc_get_shape (1);
1254 mpz_init_set_ui (result
->shape
[0], MAX (n2
-n1
+1, 0));
1259 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1260 YN(N, 0.0) = -Inf. */
1262 if (mpfr_cmp_ui (x
->value
.real
, 0.0) == 0)
1264 if (!jn
&& gfc_option
.flag_range_check
)
1266 gfc_error ("Result of BESSEL_YN is -INF at %L", &result
->where
);
1267 gfc_free_expr (result
);
1268 return &gfc_bad_expr
;
1273 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1274 mpfr_set_ui (e
->value
.real
, 1, GFC_RND_MODE
);
1275 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1280 for (i
= n1
; i
<= n2
; i
++)
1282 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1284 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
1286 mpfr_set_inf (e
->value
.real
, -1);
1287 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1294 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1295 are stable for downward recursion and Neumann functions are stable
1296 for upward recursion. It is
1298 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1299 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1300 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1302 gfc_set_model_kind (x
->ts
.kind
);
1304 /* Get first recursion anchor. */
1308 mpfr_jn (last1
, n2
, x
->value
.real
, GFC_RND_MODE
);
1310 mpfr_yn (last1
, n1
, x
->value
.real
, GFC_RND_MODE
);
1312 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1313 mpfr_set (e
->value
.real
, last1
, GFC_RND_MODE
);
1314 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1318 gfc_free_expr (result
);
1319 return &gfc_bad_expr
;
1321 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1329 /* Get second recursion anchor. */
1333 mpfr_jn (last2
, n2
-1, x
->value
.real
, GFC_RND_MODE
);
1335 mpfr_yn (last2
, n1
+1, x
->value
.real
, GFC_RND_MODE
);
1337 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1338 mpfr_set (e
->value
.real
, last2
, GFC_RND_MODE
);
1339 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1344 gfc_free_expr (result
);
1345 return &gfc_bad_expr
;
1348 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
, -2);
1350 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1359 /* Start actual recursion. */
1362 mpfr_ui_div (x2rev
, 2, x
->value
.real
, GFC_RND_MODE
);
1364 for (i
= 2; i
<= n2
-n1
; i
++)
1366 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1368 /* Special case: For YN, if the previous N gave -INF, set
1369 also N+1 to -INF. */
1370 if (!jn
&& !gfc_option
.flag_range_check
&& mpfr_inf_p (last2
))
1372 mpfr_set_inf (e
->value
.real
, -1);
1373 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1378 mpfr_mul_si (e
->value
.real
, x2rev
, jn
? (n2
-i
+1) : (n1
+i
-1),
1380 mpfr_mul (e
->value
.real
, e
->value
.real
, last2
, GFC_RND_MODE
);
1381 mpfr_sub (e
->value
.real
, e
->value
.real
, last1
, GFC_RND_MODE
);
1383 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1385 /* Range_check frees "e" in that case. */
1391 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
,
1394 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1396 mpfr_set (last1
, last2
, GFC_RND_MODE
);
1397 mpfr_set (last2
, e
->value
.real
, GFC_RND_MODE
);
1410 gfc_free_expr (result
);
1411 return &gfc_bad_expr
;
1416 gfc_simplify_bessel_jn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1418 return gfc_simplify_bessel_n2 (order1
, order2
, x
, true);
1423 gfc_simplify_bessel_y0 (gfc_expr
*x
)
1427 if (x
->expr_type
!= EXPR_CONSTANT
)
1430 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1431 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1433 return range_check (result
, "BESSEL_Y0");
1438 gfc_simplify_bessel_y1 (gfc_expr
*x
)
1442 if (x
->expr_type
!= EXPR_CONSTANT
)
1445 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1446 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1448 return range_check (result
, "BESSEL_Y1");
1453 gfc_simplify_bessel_yn (gfc_expr
*order
, gfc_expr
*x
)
1458 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1461 n
= mpz_get_si (order
->value
.integer
);
1462 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1463 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1465 return range_check (result
, "BESSEL_YN");
1470 gfc_simplify_bessel_yn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1472 return gfc_simplify_bessel_n2 (order1
, order2
, x
, false);
1477 gfc_simplify_bit_size (gfc_expr
*e
)
1479 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1480 return gfc_get_int_expr (e
->ts
.kind
, &e
->where
,
1481 gfc_integer_kinds
[i
].bit_size
);
1486 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
1490 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
1493 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
1494 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
, false);
1496 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
,
1497 mpz_tstbit (e
->value
.integer
, b
));
1502 compare_bitwise (gfc_expr
*i
, gfc_expr
*j
)
1507 gcc_assert (i
->ts
.type
== BT_INTEGER
);
1508 gcc_assert (j
->ts
.type
== BT_INTEGER
);
1510 mpz_init_set (x
, i
->value
.integer
);
1511 k
= gfc_validate_kind (i
->ts
.type
, i
->ts
.kind
, false);
1512 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
1514 mpz_init_set (y
, j
->value
.integer
);
1515 k
= gfc_validate_kind (j
->ts
.type
, j
->ts
.kind
, false);
1516 convert_mpz_to_unsigned (y
, gfc_integer_kinds
[k
].bit_size
);
1518 res
= mpz_cmp (x
, y
);
1526 gfc_simplify_bge (gfc_expr
*i
, gfc_expr
*j
)
1528 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1531 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1532 compare_bitwise (i
, j
) >= 0);
1537 gfc_simplify_bgt (gfc_expr
*i
, gfc_expr
*j
)
1539 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1542 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1543 compare_bitwise (i
, j
) > 0);
1548 gfc_simplify_ble (gfc_expr
*i
, gfc_expr
*j
)
1550 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1553 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1554 compare_bitwise (i
, j
) <= 0);
1559 gfc_simplify_blt (gfc_expr
*i
, gfc_expr
*j
)
1561 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1564 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1565 compare_bitwise (i
, j
) < 0);
1570 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
1572 gfc_expr
*ceil
, *result
;
1575 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
1577 return &gfc_bad_expr
;
1579 if (e
->expr_type
!= EXPR_CONSTANT
)
1582 ceil
= gfc_copy_expr (e
);
1583 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
1585 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
1586 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
, &e
->where
);
1588 gfc_free_expr (ceil
);
1590 return range_check (result
, "CEILING");
1595 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
1597 return simplify_achar_char (e
, k
, "CHAR", false);
1601 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1604 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
1608 if (convert_boz (x
, kind
) == &gfc_bad_expr
)
1609 return &gfc_bad_expr
;
1611 if (convert_boz (y
, kind
) == &gfc_bad_expr
)
1612 return &gfc_bad_expr
;
1614 if (x
->expr_type
!= EXPR_CONSTANT
1615 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1618 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &x
->where
);
1623 mpc_set_z (result
->value
.complex, x
->value
.integer
, GFC_MPC_RND_MODE
);
1627 mpc_set_fr (result
->value
.complex, x
->value
.real
, GFC_RND_MODE
);
1631 mpc_set (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1635 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1639 return range_check (result
, name
);
1644 mpfr_set_z (mpc_imagref (result
->value
.complex),
1645 y
->value
.integer
, GFC_RND_MODE
);
1649 mpfr_set (mpc_imagref (result
->value
.complex),
1650 y
->value
.real
, GFC_RND_MODE
);
1654 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1657 return range_check (result
, name
);
1662 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
1666 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_complex_kind
);
1668 return &gfc_bad_expr
;
1670 return simplify_cmplx ("CMPLX", x
, y
, kind
);
1675 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
1679 if (x
->ts
.type
== BT_INTEGER
&& y
->ts
.type
== BT_INTEGER
)
1680 kind
= gfc_default_complex_kind
;
1681 else if (x
->ts
.type
== BT_REAL
|| y
->ts
.type
== BT_INTEGER
)
1683 else if (x
->ts
.type
== BT_INTEGER
|| y
->ts
.type
== BT_REAL
)
1685 else if (x
->ts
.type
== BT_REAL
&& y
->ts
.type
== BT_REAL
)
1686 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
1690 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1695 gfc_simplify_conjg (gfc_expr
*e
)
1699 if (e
->expr_type
!= EXPR_CONSTANT
)
1702 result
= gfc_copy_expr (e
);
1703 mpc_conj (result
->value
.complex, result
->value
.complex, GFC_MPC_RND_MODE
);
1705 return range_check (result
, "CONJG");
1710 gfc_simplify_cos (gfc_expr
*x
)
1714 if (x
->expr_type
!= EXPR_CONSTANT
)
1717 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1722 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1726 gfc_set_model_kind (x
->ts
.kind
);
1727 mpc_cos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1731 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1734 return range_check (result
, "COS");
1739 gfc_simplify_cosh (gfc_expr
*x
)
1743 if (x
->expr_type
!= EXPR_CONSTANT
)
1746 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1751 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1755 mpc_cosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1762 return range_check (result
, "COSH");
1767 gfc_simplify_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1771 if (!is_constant_array_expr (mask
)
1772 || !gfc_is_constant_expr (dim
)
1773 || !gfc_is_constant_expr (kind
))
1776 result
= transformational_result (mask
, dim
,
1778 get_kind (BT_INTEGER
, kind
, "COUNT",
1779 gfc_default_integer_kind
),
1782 init_result_expr (result
, 0, NULL
);
1784 /* Passing MASK twice, once as data array, once as mask.
1785 Whenever gfc_count is called, '1' is added to the result. */
1786 return !dim
|| mask
->rank
== 1 ?
1787 simplify_transformation_to_scalar (result
, mask
, mask
, gfc_count
) :
1788 simplify_transformation_to_array (result
, mask
, dim
, mask
, gfc_count
, NULL
);
1793 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1795 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
1800 gfc_simplify_dble (gfc_expr
*e
)
1802 gfc_expr
*result
= NULL
;
1804 if (e
->expr_type
!= EXPR_CONSTANT
)
1807 if (convert_boz (e
, gfc_default_double_kind
) == &gfc_bad_expr
)
1808 return &gfc_bad_expr
;
1810 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
1811 if (result
== &gfc_bad_expr
)
1812 return &gfc_bad_expr
;
1814 return range_check (result
, "DBLE");
1819 gfc_simplify_digits (gfc_expr
*x
)
1823 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1828 digits
= gfc_integer_kinds
[i
].digits
;
1833 digits
= gfc_real_kinds
[i
].digits
;
1840 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
1845 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
1850 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1853 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1854 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
1859 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
1860 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1862 mpz_set_ui (result
->value
.integer
, 0);
1867 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
1868 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
1871 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1876 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1879 return range_check (result
, "DIM");
1884 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1889 if (!is_constant_array_expr (vector_a
)
1890 || !is_constant_array_expr (vector_b
))
1893 gcc_assert (vector_a
->rank
== 1);
1894 gcc_assert (vector_b
->rank
== 1);
1896 temp
.expr_type
= EXPR_OP
;
1897 gfc_clear_ts (&temp
.ts
);
1898 temp
.value
.op
.op
= INTRINSIC_NONE
;
1899 temp
.value
.op
.op1
= vector_a
;
1900 temp
.value
.op
.op2
= vector_b
;
1901 gfc_type_convert_binary (&temp
, 1);
1903 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
1908 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
1910 gfc_expr
*a1
, *a2
, *result
;
1912 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1915 a1
= gfc_real2real (x
, gfc_default_double_kind
);
1916 a2
= gfc_real2real (y
, gfc_default_double_kind
);
1918 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
1919 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
1924 return range_check (result
, "DPROD");
1929 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
1933 int i
, k
, size
, shift
;
1935 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
1936 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
1939 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
1940 size
= gfc_integer_kinds
[k
].bit_size
;
1942 gfc_extract_int (shiftarg
, &shift
);
1944 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
1946 shift
= size
- shift
;
1948 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
1949 mpz_set_ui (result
->value
.integer
, 0);
1951 for (i
= 0; i
< shift
; i
++)
1952 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
1953 mpz_setbit (result
->value
.integer
, i
);
1955 for (i
= 0; i
< size
- shift
; i
++)
1956 if (mpz_tstbit (arg1
->value
.integer
, i
))
1957 mpz_setbit (result
->value
.integer
, shift
+ i
);
1959 /* Convert to a signed value. */
1960 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
1967 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
1969 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
1974 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
1976 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
1981 gfc_simplify_erf (gfc_expr
*x
)
1985 if (x
->expr_type
!= EXPR_CONSTANT
)
1988 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1989 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1991 return range_check (result
, "ERF");
1996 gfc_simplify_erfc (gfc_expr
*x
)
2000 if (x
->expr_type
!= EXPR_CONSTANT
)
2003 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2004 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2006 return range_check (result
, "ERFC");
2010 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2012 #define MAX_ITER 200
2013 #define ARG_LIMIT 12
2015 /* Calculate ERFC_SCALED directly by its definition:
2017 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2019 using a large precision for intermediate results. This is used for all
2020 but large values of the argument. */
2022 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2027 prec
= mpfr_get_default_prec ();
2028 mpfr_set_default_prec (10 * prec
);
2033 mpfr_set (a
, arg
, GFC_RND_MODE
);
2034 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2035 mpfr_exp (b
, b
, GFC_RND_MODE
);
2036 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2037 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2039 mpfr_set (res
, a
, GFC_RND_MODE
);
2040 mpfr_set_default_prec (prec
);
2046 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2048 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2049 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2052 This is used for large values of the argument. Intermediate calculations
2053 are performed with twice the precision. We don't do a fixed number of
2054 iterations of the sum, but stop when it has converged to the required
2057 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2059 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2064 prec
= mpfr_get_default_prec ();
2065 mpfr_set_default_prec (2 * prec
);
2075 mpfr_init (sumtrunc
);
2076 mpfr_set_prec (oldsum
, prec
);
2077 mpfr_set_prec (sumtrunc
, prec
);
2079 mpfr_set (x
, arg
, GFC_RND_MODE
);
2080 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2081 mpz_set_ui (num
, 1);
2083 mpfr_set (u
, x
, GFC_RND_MODE
);
2084 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2085 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2086 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2088 for (i
= 1; i
< MAX_ITER
; i
++)
2090 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2092 mpz_mul_ui (num
, num
, 2 * i
- 1);
2095 mpfr_set (w
, u
, GFC_RND_MODE
);
2096 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2098 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2099 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2101 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2103 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2104 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2108 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2110 gcc_assert (i
< MAX_ITER
);
2112 /* Divide by x * sqrt(Pi). */
2113 mpfr_const_pi (u
, GFC_RND_MODE
);
2114 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2115 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2116 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2118 mpfr_set (res
, sum
, GFC_RND_MODE
);
2119 mpfr_set_default_prec (prec
);
2121 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2127 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2131 if (x
->expr_type
!= EXPR_CONSTANT
)
2134 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2135 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2136 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2138 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2140 return range_check (result
, "ERFC_SCALED");
2148 gfc_simplify_epsilon (gfc_expr
*e
)
2153 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2155 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2156 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2158 return range_check (result
, "EPSILON");
2163 gfc_simplify_exp (gfc_expr
*x
)
2167 if (x
->expr_type
!= EXPR_CONSTANT
)
2170 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2175 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2179 gfc_set_model_kind (x
->ts
.kind
);
2180 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2184 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2187 return range_check (result
, "EXP");
2192 gfc_simplify_exponent (gfc_expr
*x
)
2197 if (x
->expr_type
!= EXPR_CONSTANT
)
2200 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2203 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2204 if (mpfr_inf_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
2206 int i
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
2207 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2211 /* EXPONENT(+/- 0.0) = 0 */
2212 if (mpfr_zero_p (x
->value
.real
))
2214 mpz_set_ui (result
->value
.integer
, 0);
2218 gfc_set_model (x
->value
.real
);
2220 val
= (long int) mpfr_get_exp (x
->value
.real
);
2221 mpz_set_si (result
->value
.integer
, val
);
2223 return range_check (result
, "EXPONENT");
2228 gfc_simplify_float (gfc_expr
*a
)
2232 if (a
->expr_type
!= EXPR_CONSTANT
)
2237 if (convert_boz (a
, gfc_default_real_kind
) == &gfc_bad_expr
)
2238 return &gfc_bad_expr
;
2240 result
= gfc_copy_expr (a
);
2243 result
= gfc_int2real (a
, gfc_default_real_kind
);
2245 return range_check (result
, "FLOAT");
2250 is_last_ref_vtab (gfc_expr
*e
)
2253 gfc_component
*comp
= NULL
;
2255 if (e
->expr_type
!= EXPR_VARIABLE
)
2258 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2259 if (ref
->type
== REF_COMPONENT
)
2260 comp
= ref
->u
.c
.component
;
2262 if (!e
->ref
|| !comp
)
2263 return e
->symtree
->n
.sym
->attr
.vtab
;
2265 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
2273 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
2275 /* Avoid simplification of resolved symbols. */
2276 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
2279 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
2280 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2281 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2284 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
2287 /* Return .false. if the dynamic type can never be the same. */
2288 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
2289 && !gfc_type_is_extension_of
2290 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2291 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
2292 && !gfc_type_is_extension_of
2293 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
2294 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
2295 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
2296 && !gfc_type_is_extension_of
2298 mold
->ts
.u
.derived
->components
->ts
.u
.derived
)
2299 && !gfc_type_is_extension_of
2300 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2302 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
2303 && !gfc_type_is_extension_of
2304 (mold
->ts
.u
.derived
,
2305 a
->ts
.u
.derived
->components
->ts
.u
.derived
)))
2306 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2308 if (mold
->ts
.type
== BT_DERIVED
2309 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2310 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
2311 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
2318 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
2320 /* Avoid simplification of resolved symbols. */
2321 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
2324 /* Return .false. if the dynamic type can never be the
2326 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
2327 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
2328 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
2329 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
2330 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2332 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
2335 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2336 gfc_compare_derived_types (a
->ts
.u
.derived
,
2342 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
2348 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
2350 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2352 if (e
->expr_type
!= EXPR_CONSTANT
)
2355 gfc_set_model_kind (kind
);
2358 mpfr_floor (floor
, e
->value
.real
);
2360 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
2361 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
2365 return range_check (result
, "FLOOR");
2370 gfc_simplify_fraction (gfc_expr
*x
)
2374 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2375 mpfr_t absv
, exp
, pow2
;
2380 if (x
->expr_type
!= EXPR_CONSTANT
)
2383 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
2385 /* FRACTION(inf) = NaN. */
2386 if (mpfr_inf_p (x
->value
.real
))
2388 mpfr_set_nan (result
->value
.real
);
2392 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2394 /* MPFR versions before 3.1.0 do not include mpfr_frexp.
2395 TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
2397 if (mpfr_sgn (x
->value
.real
) == 0)
2399 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2403 gfc_set_model_kind (x
->ts
.kind
);
2408 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
2409 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
2411 mpfr_trunc (exp
, exp
);
2412 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
2414 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
2416 mpfr_div (result
->value
.real
, x
->value
.real
, pow2
, GFC_RND_MODE
);
2418 mpfr_clears (exp
, absv
, pow2
, NULL
);
2422 /* mpfr_frexp() correctly handles zeros and NaNs. */
2423 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2427 return range_check (result
, "FRACTION");
2432 gfc_simplify_gamma (gfc_expr
*x
)
2436 if (x
->expr_type
!= EXPR_CONSTANT
)
2439 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2440 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2442 return range_check (result
, "GAMMA");
2447 gfc_simplify_huge (gfc_expr
*e
)
2452 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2453 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2458 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2462 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
2474 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
2478 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2481 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2482 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
2483 return range_check (result
, "HYPOT");
2487 /* We use the processor's collating sequence, because all
2488 systems that gfortran currently works on are ASCII. */
2491 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
2497 if (e
->expr_type
!= EXPR_CONSTANT
)
2500 if (e
->value
.character
.length
!= 1)
2502 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
2503 return &gfc_bad_expr
;
2506 index
= e
->value
.character
.string
[0];
2508 if (gfc_option
.warn_surprising
&& index
> 127)
2509 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
2512 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
2514 return &gfc_bad_expr
;
2516 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2518 return range_check (result
, "IACHAR");
2523 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
2525 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2526 gcc_assert (result
->ts
.type
== BT_INTEGER
2527 && result
->expr_type
== EXPR_CONSTANT
);
2529 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2535 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2537 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
2542 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
2544 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2545 gcc_assert (result
->ts
.type
== BT_INTEGER
2546 && result
->expr_type
== EXPR_CONSTANT
);
2548 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2554 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2556 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
2561 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
2565 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2568 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2569 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2571 return range_check (result
, "IAND");
2576 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
2581 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2584 gfc_extract_int (y
, &pos
);
2586 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2588 result
= gfc_copy_expr (x
);
2590 convert_mpz_to_unsigned (result
->value
.integer
,
2591 gfc_integer_kinds
[k
].bit_size
);
2593 mpz_clrbit (result
->value
.integer
, pos
);
2595 gfc_convert_mpz_to_signed (result
->value
.integer
,
2596 gfc_integer_kinds
[k
].bit_size
);
2603 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
2610 if (x
->expr_type
!= EXPR_CONSTANT
2611 || y
->expr_type
!= EXPR_CONSTANT
2612 || z
->expr_type
!= EXPR_CONSTANT
)
2615 gfc_extract_int (y
, &pos
);
2616 gfc_extract_int (z
, &len
);
2618 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
2620 bitsize
= gfc_integer_kinds
[k
].bit_size
;
2622 if (pos
+ len
> bitsize
)
2624 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2625 "bit size at %L", &y
->where
);
2626 return &gfc_bad_expr
;
2629 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2630 convert_mpz_to_unsigned (result
->value
.integer
,
2631 gfc_integer_kinds
[k
].bit_size
);
2633 bits
= XCNEWVEC (int, bitsize
);
2635 for (i
= 0; i
< bitsize
; i
++)
2638 for (i
= 0; i
< len
; i
++)
2639 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
2641 for (i
= 0; i
< bitsize
; i
++)
2644 mpz_clrbit (result
->value
.integer
, i
);
2645 else if (bits
[i
] == 1)
2646 mpz_setbit (result
->value
.integer
, i
);
2648 gfc_internal_error ("IBITS: Bad bit");
2653 gfc_convert_mpz_to_signed (result
->value
.integer
,
2654 gfc_integer_kinds
[k
].bit_size
);
2661 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
2666 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2669 gfc_extract_int (y
, &pos
);
2671 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2673 result
= gfc_copy_expr (x
);
2675 convert_mpz_to_unsigned (result
->value
.integer
,
2676 gfc_integer_kinds
[k
].bit_size
);
2678 mpz_setbit (result
->value
.integer
, pos
);
2680 gfc_convert_mpz_to_signed (result
->value
.integer
,
2681 gfc_integer_kinds
[k
].bit_size
);
2688 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
2694 if (e
->expr_type
!= EXPR_CONSTANT
)
2697 if (e
->value
.character
.length
!= 1)
2699 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
2700 return &gfc_bad_expr
;
2703 index
= e
->value
.character
.string
[0];
2705 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
2707 return &gfc_bad_expr
;
2709 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2711 return range_check (result
, "ICHAR");
2716 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
2720 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2723 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2724 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2726 return range_check (result
, "IEOR");
2731 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
2734 int back
, len
, lensub
;
2735 int i
, j
, k
, count
, index
= 0, start
;
2737 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
2738 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
2741 if (b
!= NULL
&& b
->value
.logical
!= 0)
2746 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
2748 return &gfc_bad_expr
;
2750 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
2752 len
= x
->value
.character
.length
;
2753 lensub
= y
->value
.character
.length
;
2757 mpz_set_si (result
->value
.integer
, 0);
2765 mpz_set_si (result
->value
.integer
, 1);
2768 else if (lensub
== 1)
2770 for (i
= 0; i
< len
; i
++)
2772 for (j
= 0; j
< lensub
; j
++)
2774 if (y
->value
.character
.string
[j
]
2775 == x
->value
.character
.string
[i
])
2785 for (i
= 0; i
< len
; i
++)
2787 for (j
= 0; j
< lensub
; j
++)
2789 if (y
->value
.character
.string
[j
]
2790 == x
->value
.character
.string
[i
])
2795 for (k
= 0; k
< lensub
; k
++)
2797 if (y
->value
.character
.string
[k
]
2798 == x
->value
.character
.string
[k
+ start
])
2802 if (count
== lensub
)
2817 mpz_set_si (result
->value
.integer
, len
+ 1);
2820 else if (lensub
== 1)
2822 for (i
= 0; i
< len
; i
++)
2824 for (j
= 0; j
< lensub
; j
++)
2826 if (y
->value
.character
.string
[j
]
2827 == x
->value
.character
.string
[len
- i
])
2829 index
= len
- i
+ 1;
2837 for (i
= 0; i
< len
; i
++)
2839 for (j
= 0; j
< lensub
; j
++)
2841 if (y
->value
.character
.string
[j
]
2842 == x
->value
.character
.string
[len
- i
])
2845 if (start
<= len
- lensub
)
2848 for (k
= 0; k
< lensub
; k
++)
2849 if (y
->value
.character
.string
[k
]
2850 == x
->value
.character
.string
[k
+ start
])
2853 if (count
== lensub
)
2870 mpz_set_si (result
->value
.integer
, index
);
2871 return range_check (result
, "INDEX");
2876 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
2878 gfc_expr
*result
= NULL
;
2880 if (e
->expr_type
!= EXPR_CONSTANT
)
2883 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
2884 if (result
== &gfc_bad_expr
)
2885 return &gfc_bad_expr
;
2887 return range_check (result
, name
);
2892 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
2896 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
2898 return &gfc_bad_expr
;
2900 return simplify_intconv (e
, kind
, "INT");
2904 gfc_simplify_int2 (gfc_expr
*e
)
2906 return simplify_intconv (e
, 2, "INT2");
2911 gfc_simplify_int8 (gfc_expr
*e
)
2913 return simplify_intconv (e
, 8, "INT8");
2918 gfc_simplify_long (gfc_expr
*e
)
2920 return simplify_intconv (e
, 4, "LONG");
2925 gfc_simplify_ifix (gfc_expr
*e
)
2927 gfc_expr
*rtrunc
, *result
;
2929 if (e
->expr_type
!= EXPR_CONSTANT
)
2932 rtrunc
= gfc_copy_expr (e
);
2933 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
2935 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2937 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
2939 gfc_free_expr (rtrunc
);
2941 return range_check (result
, "IFIX");
2946 gfc_simplify_idint (gfc_expr
*e
)
2948 gfc_expr
*rtrunc
, *result
;
2950 if (e
->expr_type
!= EXPR_CONSTANT
)
2953 rtrunc
= gfc_copy_expr (e
);
2954 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
2956 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2958 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
2960 gfc_free_expr (rtrunc
);
2962 return range_check (result
, "IDINT");
2967 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
2971 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2974 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2975 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2977 return range_check (result
, "IOR");
2982 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
2984 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2985 gcc_assert (result
->ts
.type
== BT_INTEGER
2986 && result
->expr_type
== EXPR_CONSTANT
);
2988 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2994 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2996 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3001 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3003 if (x
->expr_type
!= EXPR_CONSTANT
)
3006 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3007 mpz_cmp_si (x
->value
.integer
,
3008 LIBERROR_END
) == 0);
3013 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3015 if (x
->expr_type
!= EXPR_CONSTANT
)
3018 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3019 mpz_cmp_si (x
->value
.integer
,
3020 LIBERROR_EOR
) == 0);
3025 gfc_simplify_isnan (gfc_expr
*x
)
3027 if (x
->expr_type
!= EXPR_CONSTANT
)
3030 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3031 mpfr_nan_p (x
->value
.real
));
3035 /* Performs a shift on its first argument. Depending on the last
3036 argument, the shift can be arithmetic, i.e. with filling from the
3037 left like in the SHIFTA intrinsic. */
3039 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3040 bool arithmetic
, int direction
)
3043 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3045 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3048 gfc_extract_int (s
, &shift
);
3050 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3051 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3053 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3057 mpz_set (result
->value
.integer
, e
->value
.integer
);
3061 if (direction
> 0 && shift
< 0)
3063 /* Left shift, as in SHIFTL. */
3064 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3065 return &gfc_bad_expr
;
3067 else if (direction
< 0)
3069 /* Right shift, as in SHIFTR or SHIFTA. */
3072 gfc_error ("Second argument of %s is negative at %L",
3074 return &gfc_bad_expr
;
3080 ashift
= (shift
>= 0 ? shift
: -shift
);
3082 if (ashift
> bitsize
)
3084 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3085 "at %L", name
, &e
->where
);
3086 return &gfc_bad_expr
;
3089 bits
= XCNEWVEC (int, bitsize
);
3091 for (i
= 0; i
< bitsize
; i
++)
3092 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3097 for (i
= 0; i
< shift
; i
++)
3098 mpz_clrbit (result
->value
.integer
, i
);
3100 for (i
= 0; i
< bitsize
- shift
; i
++)
3103 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3105 mpz_setbit (result
->value
.integer
, i
+ shift
);
3111 if (arithmetic
&& bits
[bitsize
- 1])
3112 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3113 mpz_setbit (result
->value
.integer
, i
);
3115 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3116 mpz_clrbit (result
->value
.integer
, i
);
3118 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3121 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3123 mpz_setbit (result
->value
.integer
, i
- ashift
);
3127 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3135 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3137 return simplify_shift (e
, s
, "ISHFT", false, 0);
3142 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3144 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3149 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3151 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3156 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3158 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3163 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3165 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3170 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3172 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3177 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3180 int shift
, ashift
, isize
, ssize
, delta
, k
;
3183 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3186 gfc_extract_int (s
, &shift
);
3188 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3189 isize
= gfc_integer_kinds
[k
].bit_size
;
3193 if (sz
->expr_type
!= EXPR_CONSTANT
)
3196 gfc_extract_int (sz
, &ssize
);
3210 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3211 "BIT_SIZE of first argument at %L", &s
->where
);
3212 return &gfc_bad_expr
;
3215 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3217 mpz_set (result
->value
.integer
, e
->value
.integer
);
3222 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
3224 bits
= XCNEWVEC (int, ssize
);
3226 for (i
= 0; i
< ssize
; i
++)
3227 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3229 delta
= ssize
- ashift
;
3233 for (i
= 0; i
< delta
; i
++)
3236 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3238 mpz_setbit (result
->value
.integer
, i
+ shift
);
3241 for (i
= delta
; i
< ssize
; i
++)
3244 mpz_clrbit (result
->value
.integer
, i
- delta
);
3246 mpz_setbit (result
->value
.integer
, i
- delta
);
3251 for (i
= 0; i
< ashift
; i
++)
3254 mpz_clrbit (result
->value
.integer
, i
+ delta
);
3256 mpz_setbit (result
->value
.integer
, i
+ delta
);
3259 for (i
= ashift
; i
< ssize
; i
++)
3262 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3264 mpz_setbit (result
->value
.integer
, i
+ shift
);
3268 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
3276 gfc_simplify_kind (gfc_expr
*e
)
3278 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
3283 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
3284 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
3286 gfc_expr
*l
, *u
, *result
;
3289 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3290 gfc_default_integer_kind
);
3292 return &gfc_bad_expr
;
3294 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3296 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3297 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3298 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
3302 gfc_expr
* dim
= result
;
3303 mpz_set_si (dim
->value
.integer
, d
);
3305 result
= simplify_size (array
, dim
, k
);
3306 gfc_free_expr (dim
);
3311 mpz_set_si (result
->value
.integer
, 1);
3316 /* Otherwise, we have a variable expression. */
3317 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
3320 if (!gfc_resolve_array_spec (as
, 0))
3323 /* The last dimension of an assumed-size array is special. */
3324 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
3325 || (coarray
&& d
== as
->rank
+ as
->corank
3326 && (!upper
|| gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)))
3328 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
3330 gfc_free_expr (result
);
3331 return gfc_copy_expr (as
->lower
[d
-1]);
3337 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3339 /* Then, we need to know the extent of the given dimension. */
3340 if (coarray
|| ref
->u
.ar
.type
== AR_FULL
)
3345 if (l
->expr_type
!= EXPR_CONSTANT
|| u
== NULL
3346 || u
->expr_type
!= EXPR_CONSTANT
)
3349 if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
3353 mpz_set_si (result
->value
.integer
, 0);
3355 mpz_set_si (result
->value
.integer
, 1);
3359 /* Nonzero extent. */
3361 mpz_set (result
->value
.integer
, u
->value
.integer
);
3363 mpz_set (result
->value
.integer
, l
->value
.integer
);
3370 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d
- 1, &result
->value
.integer
, NULL
))
3374 mpz_set_si (result
->value
.integer
, (long int) 1);
3378 return range_check (result
, upper
? "UBOUND" : "LBOUND");
3381 gfc_free_expr (result
);
3387 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3393 if (array
->ts
.type
== BT_CLASS
)
3396 if (array
->expr_type
!= EXPR_VARIABLE
)
3403 /* Follow any component references. */
3404 as
= array
->symtree
->n
.sym
->as
;
3405 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3410 switch (ref
->u
.ar
.type
)
3417 /* We're done because 'as' has already been set in the
3418 previous iteration. */
3435 as
= ref
->u
.c
.component
->as
;
3447 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
3448 || as
->type
== AS_ASSUMED_RANK
))
3453 /* Multi-dimensional bounds. */
3454 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3458 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
3459 if (upper
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
3461 /* An error message will be emitted in
3462 check_assumed_size_reference (resolve.c). */
3463 return &gfc_bad_expr
;
3466 /* Simplify the bounds for each dimension. */
3467 for (d
= 0; d
< array
->rank
; d
++)
3469 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
3471 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3475 for (j
= 0; j
< d
; j
++)
3476 gfc_free_expr (bounds
[j
]);
3481 /* Allocate the result expression. */
3482 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3483 gfc_default_integer_kind
);
3485 return &gfc_bad_expr
;
3487 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
3489 /* The result is a rank 1 array; its size is the rank of the first
3490 argument to {L,U}BOUND. */
3492 e
->shape
= gfc_get_shape (1);
3493 mpz_init_set_ui (e
->shape
[0], array
->rank
);
3495 /* Create the constructor for this array. */
3496 for (d
= 0; d
< array
->rank
; d
++)
3497 gfc_constructor_append_expr (&e
->value
.constructor
,
3498 bounds
[d
], &e
->where
);
3504 /* A DIM argument is specified. */
3505 if (dim
->expr_type
!= EXPR_CONSTANT
)
3508 d
= mpz_get_si (dim
->value
.integer
);
3510 if ((d
< 1 || d
> array
->rank
)
3511 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
3513 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3514 return &gfc_bad_expr
;
3517 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3520 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
3526 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3532 if (array
->expr_type
!= EXPR_VARIABLE
)
3535 /* Follow any component references. */
3536 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
3537 ? array
->ts
.u
.derived
->components
->as
3538 : array
->symtree
->n
.sym
->as
;
3539 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3544 switch (ref
->u
.ar
.type
)
3547 if (ref
->u
.ar
.as
->corank
> 0)
3549 gcc_assert (as
== ref
->u
.ar
.as
);
3556 /* We're done because 'as' has already been set in the
3557 previous iteration. */
3574 as
= ref
->u
.c
.component
->as
;
3587 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
3592 /* Multi-dimensional cobounds. */
3593 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3597 /* Simplify the cobounds for each dimension. */
3598 for (d
= 0; d
< as
->corank
; d
++)
3600 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
3601 upper
, as
, ref
, true);
3602 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3606 for (j
= 0; j
< d
; j
++)
3607 gfc_free_expr (bounds
[j
]);
3612 /* Allocate the result expression. */
3613 e
= gfc_get_expr ();
3614 e
->where
= array
->where
;
3615 e
->expr_type
= EXPR_ARRAY
;
3616 e
->ts
.type
= BT_INTEGER
;
3617 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
3618 gfc_default_integer_kind
);
3622 return &gfc_bad_expr
;
3626 /* The result is a rank 1 array; its size is the rank of the first
3627 argument to {L,U}COBOUND. */
3629 e
->shape
= gfc_get_shape (1);
3630 mpz_init_set_ui (e
->shape
[0], as
->corank
);
3632 /* Create the constructor for this array. */
3633 for (d
= 0; d
< as
->corank
; d
++)
3634 gfc_constructor_append_expr (&e
->value
.constructor
,
3635 bounds
[d
], &e
->where
);
3640 /* A DIM argument is specified. */
3641 if (dim
->expr_type
!= EXPR_CONSTANT
)
3644 d
= mpz_get_si (dim
->value
.integer
);
3646 if (d
< 1 || d
> as
->corank
)
3648 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3649 return &gfc_bad_expr
;
3652 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
3658 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3660 return simplify_bound (array
, dim
, kind
, 0);
3665 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3667 return simplify_cobound (array
, dim
, kind
, 0);
3671 gfc_simplify_leadz (gfc_expr
*e
)
3673 unsigned long lz
, bs
;
3676 if (e
->expr_type
!= EXPR_CONSTANT
)
3679 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3680 bs
= gfc_integer_kinds
[i
].bit_size
;
3681 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
3683 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
3686 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
3688 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
3693 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
3696 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
3699 return &gfc_bad_expr
;
3701 if (e
->expr_type
== EXPR_CONSTANT
)
3703 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3704 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
3705 return range_check (result
, "LEN");
3707 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
3708 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3709 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
3711 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3712 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
3713 return range_check (result
, "LEN");
3721 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
3725 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
3728 return &gfc_bad_expr
;
3730 if (e
->expr_type
!= EXPR_CONSTANT
)
3733 len
= e
->value
.character
.length
;
3734 for (count
= 0, i
= 1; i
<= len
; i
++)
3735 if (e
->value
.character
.string
[len
- i
] == ' ')
3740 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
3741 return range_check (result
, "LEN_TRIM");
3745 gfc_simplify_lgamma (gfc_expr
*x
)
3750 if (x
->expr_type
!= EXPR_CONSTANT
)
3753 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3754 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
3756 return range_check (result
, "LGAMMA");
3761 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
3763 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3766 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3767 gfc_compare_string (a
, b
) >= 0);
3772 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
3774 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3777 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3778 gfc_compare_string (a
, b
) > 0);
3783 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
3785 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3788 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3789 gfc_compare_string (a
, b
) <= 0);
3794 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
3796 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3799 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3800 gfc_compare_string (a
, b
) < 0);
3805 gfc_simplify_log (gfc_expr
*x
)
3809 if (x
->expr_type
!= EXPR_CONSTANT
)
3812 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3817 if (mpfr_sgn (x
->value
.real
) <= 0)
3819 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3820 "to zero", &x
->where
);
3821 gfc_free_expr (result
);
3822 return &gfc_bad_expr
;
3825 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3829 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
3830 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
3832 gfc_error ("Complex argument of LOG at %L cannot be zero",
3834 gfc_free_expr (result
);
3835 return &gfc_bad_expr
;
3838 gfc_set_model_kind (x
->ts
.kind
);
3839 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
3843 gfc_internal_error ("gfc_simplify_log: bad type");
3846 return range_check (result
, "LOG");
3851 gfc_simplify_log10 (gfc_expr
*x
)
3855 if (x
->expr_type
!= EXPR_CONSTANT
)
3858 if (mpfr_sgn (x
->value
.real
) <= 0)
3860 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3861 "to zero", &x
->where
);
3862 return &gfc_bad_expr
;
3865 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3866 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3868 return range_check (result
, "LOG10");
3873 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
3877 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
3879 return &gfc_bad_expr
;
3881 if (e
->expr_type
!= EXPR_CONSTANT
)
3884 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
3889 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3892 int row
, result_rows
, col
, result_columns
;
3893 int stride_a
, offset_a
, stride_b
, offset_b
;
3895 if (!is_constant_array_expr (matrix_a
)
3896 || !is_constant_array_expr (matrix_b
))
3899 gcc_assert (gfc_compare_types (&matrix_a
->ts
, &matrix_b
->ts
));
3900 result
= gfc_get_array_expr (matrix_a
->ts
.type
,
3904 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
3907 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
3909 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
3912 result
->shape
= gfc_get_shape (result
->rank
);
3913 mpz_init_set_si (result
->shape
[0], result_columns
);
3915 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
3917 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
3919 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
3923 result
->shape
= gfc_get_shape (result
->rank
);
3924 mpz_init_set_si (result
->shape
[0], result_rows
);
3926 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
3928 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
3929 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
3930 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
3931 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
3934 result
->shape
= gfc_get_shape (result
->rank
);
3935 mpz_init_set_si (result
->shape
[0], result_rows
);
3936 mpz_init_set_si (result
->shape
[1], result_columns
);
3941 offset_a
= offset_b
= 0;
3942 for (col
= 0; col
< result_columns
; ++col
)
3946 for (row
= 0; row
< result_rows
; ++row
)
3948 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
3949 matrix_b
, 1, offset_b
, false);
3950 gfc_constructor_append_expr (&result
->value
.constructor
,
3956 offset_b
+= stride_b
;
3964 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
3970 if (i
->expr_type
!= EXPR_CONSTANT
)
3973 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
3975 return &gfc_bad_expr
;
3976 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3978 s
= gfc_extract_int (i
, &arg
);
3981 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
3983 /* MASKR(n) = 2^n - 1 */
3984 mpz_set_ui (result
->value
.integer
, 1);
3985 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
3986 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
3988 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
3995 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4002 if (i
->expr_type
!= EXPR_CONSTANT
)
4005 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4007 return &gfc_bad_expr
;
4008 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4010 s
= gfc_extract_int (i
, &arg
);
4013 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4015 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4016 mpz_init_set_ui (z
, 1);
4017 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4018 mpz_set_ui (result
->value
.integer
, 1);
4019 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4020 gfc_integer_kinds
[k
].bit_size
- arg
);
4021 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4024 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4031 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4034 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4036 if (mask
->expr_type
== EXPR_CONSTANT
)
4037 return gfc_get_parentheses (gfc_copy_expr (mask
->value
.logical
4038 ? tsource
: fsource
));
4040 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4041 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4044 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4046 if (tsource
->ts
.type
== BT_DERIVED
)
4047 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4048 else if (tsource
->ts
.type
== BT_CHARACTER
)
4049 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4051 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4052 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4053 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4057 if (mask_ctor
->expr
->value
.logical
)
4058 gfc_constructor_append_expr (&result
->value
.constructor
,
4059 gfc_copy_expr (tsource_ctor
->expr
),
4062 gfc_constructor_append_expr (&result
->value
.constructor
,
4063 gfc_copy_expr (fsource_ctor
->expr
),
4065 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4066 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4067 mask_ctor
= gfc_constructor_next (mask_ctor
);
4070 result
->shape
= gfc_get_shape (1);
4071 gfc_array_size (result
, &result
->shape
[0]);
4078 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4080 mpz_t arg1
, arg2
, mask
;
4083 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4084 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4087 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4089 /* Convert all argument to unsigned. */
4090 mpz_init_set (arg1
, i
->value
.integer
);
4091 mpz_init_set (arg2
, j
->value
.integer
);
4092 mpz_init_set (mask
, mask_expr
->value
.integer
);
4094 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4095 mpz_and (arg1
, arg1
, mask
);
4096 mpz_com (mask
, mask
);
4097 mpz_and (arg2
, arg2
, mask
);
4098 mpz_ior (result
->value
.integer
, arg1
, arg2
);
4108 /* Selects between current value and extremum for simplify_min_max
4109 and simplify_minval_maxval. */
4111 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
)
4113 switch (arg
->ts
.type
)
4116 if (mpz_cmp (arg
->value
.integer
,
4117 extremum
->value
.integer
) * sign
> 0)
4118 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
4122 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4124 mpfr_max (extremum
->value
.real
, extremum
->value
.real
,
4125 arg
->value
.real
, GFC_RND_MODE
);
4127 mpfr_min (extremum
->value
.real
, extremum
->value
.real
,
4128 arg
->value
.real
, GFC_RND_MODE
);
4132 #define LENGTH(x) ((x)->value.character.length)
4133 #define STRING(x) ((x)->value.character.string)
4134 if (LENGTH (extremum
) < LENGTH(arg
))
4136 gfc_char_t
*tmp
= STRING(extremum
);
4138 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
4139 memcpy (STRING(extremum
), tmp
,
4140 LENGTH(extremum
) * sizeof (gfc_char_t
));
4141 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
4142 LENGTH(arg
) - LENGTH(extremum
));
4143 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
4144 LENGTH(extremum
) = LENGTH(arg
);
4148 if (gfc_compare_string (arg
, extremum
) * sign
> 0)
4150 free (STRING(extremum
));
4151 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
4152 memcpy (STRING(extremum
), STRING(arg
),
4153 LENGTH(arg
) * sizeof (gfc_char_t
));
4154 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
4155 LENGTH(extremum
) - LENGTH(arg
));
4156 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
4163 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4168 /* This function is special since MAX() can take any number of
4169 arguments. The simplified expression is a rewritten version of the
4170 argument list containing at most one constant element. Other
4171 constant elements are deleted. Because the argument list has
4172 already been checked, this function always succeeds. sign is 1 for
4173 MAX(), -1 for MIN(). */
4176 simplify_min_max (gfc_expr
*expr
, int sign
)
4178 gfc_actual_arglist
*arg
, *last
, *extremum
;
4179 gfc_intrinsic_sym
* specific
;
4183 specific
= expr
->value
.function
.isym
;
4185 arg
= expr
->value
.function
.actual
;
4187 for (; arg
; last
= arg
, arg
= arg
->next
)
4189 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
4192 if (extremum
== NULL
)
4198 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
4200 /* Delete the extra constant argument. */
4201 last
->next
= arg
->next
;
4204 gfc_free_actual_arglist (arg
);
4208 /* If there is one value left, replace the function call with the
4210 if (expr
->value
.function
.actual
->next
!= NULL
)
4213 /* Convert to the correct type and kind. */
4214 if (expr
->ts
.type
!= BT_UNKNOWN
)
4215 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4216 expr
->ts
.type
, expr
->ts
.kind
);
4218 if (specific
->ts
.type
!= BT_UNKNOWN
)
4219 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4220 specific
->ts
.type
, specific
->ts
.kind
);
4222 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
4227 gfc_simplify_min (gfc_expr
*e
)
4229 return simplify_min_max (e
, -1);
4234 gfc_simplify_max (gfc_expr
*e
)
4236 return simplify_min_max (e
, 1);
4240 /* This is a simplified version of simplify_min_max to provide
4241 simplification of minval and maxval for a vector. */
4244 simplify_minval_maxval (gfc_expr
*expr
, int sign
)
4246 gfc_constructor
*c
, *extremum
;
4247 gfc_intrinsic_sym
* specific
;
4250 specific
= expr
->value
.function
.isym
;
4252 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4253 c
; c
= gfc_constructor_next (c
))
4255 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4258 if (extremum
== NULL
)
4264 min_max_choose (c
->expr
, extremum
->expr
, sign
);
4267 if (extremum
== NULL
)
4270 /* Convert to the correct type and kind. */
4271 if (expr
->ts
.type
!= BT_UNKNOWN
)
4272 return gfc_convert_constant (extremum
->expr
,
4273 expr
->ts
.type
, expr
->ts
.kind
);
4275 if (specific
->ts
.type
!= BT_UNKNOWN
)
4276 return gfc_convert_constant (extremum
->expr
,
4277 specific
->ts
.type
, specific
->ts
.kind
);
4279 return gfc_copy_expr (extremum
->expr
);
4284 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4286 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4289 return simplify_minval_maxval (array
, -1);
4294 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4296 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4299 return simplify_minval_maxval (array
, 1);
4304 gfc_simplify_maxexponent (gfc_expr
*x
)
4306 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4307 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4308 gfc_real_kinds
[i
].max_exponent
);
4313 gfc_simplify_minexponent (gfc_expr
*x
)
4315 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4316 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4317 gfc_real_kinds
[i
].min_exponent
);
4322 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
4327 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4330 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4331 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4336 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4338 /* Result is processor-dependent. */
4339 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
4340 gfc_free_expr (result
);
4341 return &gfc_bad_expr
;
4343 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4347 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4349 /* Result is processor-dependent. */
4350 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
4351 gfc_free_expr (result
);
4352 return &gfc_bad_expr
;
4355 gfc_set_model_kind (kind
);
4356 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4361 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4364 return range_check (result
, "MOD");
4369 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
4374 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4377 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4378 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4383 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4385 /* Result is processor-dependent. This processor just opts
4386 to not handle it at all. */
4387 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
4388 gfc_free_expr (result
);
4389 return &gfc_bad_expr
;
4391 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4396 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4398 /* Result is processor-dependent. */
4399 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
4400 gfc_free_expr (result
);
4401 return &gfc_bad_expr
;
4404 gfc_set_model_kind (kind
);
4405 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4407 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
4409 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
4410 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
4414 mpfr_copysign (result
->value
.real
, result
->value
.real
,
4415 p
->value
.real
, GFC_RND_MODE
);
4419 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4422 return range_check (result
, "MODULO");
4426 /* Exists for the sole purpose of consistency with other intrinsics. */
4428 gfc_simplify_mvbits (gfc_expr
*f ATTRIBUTE_UNUSED
,
4429 gfc_expr
*fp ATTRIBUTE_UNUSED
,
4430 gfc_expr
*l ATTRIBUTE_UNUSED
,
4431 gfc_expr
*to ATTRIBUTE_UNUSED
,
4432 gfc_expr
*tp ATTRIBUTE_UNUSED
)
4439 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
4442 mp_exp_t emin
, emax
;
4445 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
4448 result
= gfc_copy_expr (x
);
4450 /* Save current values of emin and emax. */
4451 emin
= mpfr_get_emin ();
4452 emax
= mpfr_get_emax ();
4454 /* Set emin and emax for the current model number. */
4455 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
4456 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
4457 mpfr_get_prec(result
->value
.real
) + 1);
4458 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
4459 mpfr_check_range (result
->value
.real
, 0, GMP_RNDU
);
4461 if (mpfr_sgn (s
->value
.real
) > 0)
4463 mpfr_nextabove (result
->value
.real
);
4464 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
4468 mpfr_nextbelow (result
->value
.real
);
4469 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
4472 mpfr_set_emin (emin
);
4473 mpfr_set_emax (emax
);
4475 /* Only NaN can occur. Do not use range check as it gives an
4476 error for denormal numbers. */
4477 if (mpfr_nan_p (result
->value
.real
) && gfc_option
.flag_range_check
)
4479 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
4480 gfc_free_expr (result
);
4481 return &gfc_bad_expr
;
4489 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
4491 gfc_expr
*itrunc
, *result
;
4494 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
4496 return &gfc_bad_expr
;
4498 if (e
->expr_type
!= EXPR_CONSTANT
)
4501 itrunc
= gfc_copy_expr (e
);
4502 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
4504 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
4505 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
4507 gfc_free_expr (itrunc
);
4509 return range_check (result
, name
);
4514 gfc_simplify_new_line (gfc_expr
*e
)
4518 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
4519 result
->value
.character
.string
[0] = '\n';
4526 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
4528 return simplify_nint ("NINT", e
, k
);
4533 gfc_simplify_idnint (gfc_expr
*e
)
4535 return simplify_nint ("IDNINT", e
, NULL
);
4540 add_squared (gfc_expr
*result
, gfc_expr
*e
)
4544 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4545 gcc_assert (result
->ts
.type
== BT_REAL
4546 && result
->expr_type
== EXPR_CONSTANT
);
4548 gfc_set_model_kind (result
->ts
.kind
);
4550 mpfr_pow_ui (tmp
, e
->value
.real
, 2, GFC_RND_MODE
);
4551 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
4560 do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
4562 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4563 gcc_assert (result
->ts
.type
== BT_REAL
4564 && result
->expr_type
== EXPR_CONSTANT
);
4566 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
4567 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4573 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
4577 if (!is_constant_array_expr (e
)
4578 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
4581 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4582 init_result_expr (result
, 0, NULL
);
4584 if (!dim
|| e
->rank
== 1)
4586 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
4588 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4591 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
4592 add_squared
, &do_sqrt
);
4599 gfc_simplify_not (gfc_expr
*e
)
4603 if (e
->expr_type
!= EXPR_CONSTANT
)
4606 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4607 mpz_com (result
->value
.integer
, e
->value
.integer
);
4609 return range_check (result
, "NOT");
4614 gfc_simplify_null (gfc_expr
*mold
)
4620 result
= gfc_copy_expr (mold
);
4621 result
->expr_type
= EXPR_NULL
;
4624 result
= gfc_get_null_expr (NULL
);
4631 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
4635 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4637 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4638 return &gfc_bad_expr
;
4641 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
4644 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
4647 /* FIXME: gfc_current_locus is wrong. */
4648 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
4649 &gfc_current_locus
);
4651 if (failed
&& failed
->value
.logical
!= 0)
4652 mpz_set_si (result
->value
.integer
, 0);
4654 mpz_set_si (result
->value
.integer
, 1);
4661 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
4666 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4669 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4674 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
4675 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4676 return range_check (result
, "OR");
4679 return gfc_get_logical_expr (kind
, &x
->where
,
4680 x
->value
.logical
|| y
->value
.logical
);
4688 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4691 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
4693 if (!is_constant_array_expr (array
)
4694 || !is_constant_array_expr (vector
)
4695 || (!gfc_is_constant_expr (mask
)
4696 && !is_constant_array_expr (mask
)))
4699 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
4700 if (array
->ts
.type
== BT_DERIVED
)
4701 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
4703 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
4704 vector_ctor
= vector
4705 ? gfc_constructor_first (vector
->value
.constructor
)
4708 if (mask
->expr_type
== EXPR_CONSTANT
4709 && mask
->value
.logical
)
4711 /* Copy all elements of ARRAY to RESULT. */
4714 gfc_constructor_append_expr (&result
->value
.constructor
,
4715 gfc_copy_expr (array_ctor
->expr
),
4718 array_ctor
= gfc_constructor_next (array_ctor
);
4719 vector_ctor
= gfc_constructor_next (vector_ctor
);
4722 else if (mask
->expr_type
== EXPR_ARRAY
)
4724 /* Copy only those elements of ARRAY to RESULT whose
4725 MASK equals .TRUE.. */
4726 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4729 if (mask_ctor
->expr
->value
.logical
)
4731 gfc_constructor_append_expr (&result
->value
.constructor
,
4732 gfc_copy_expr (array_ctor
->expr
),
4734 vector_ctor
= gfc_constructor_next (vector_ctor
);
4737 array_ctor
= gfc_constructor_next (array_ctor
);
4738 mask_ctor
= gfc_constructor_next (mask_ctor
);
4742 /* Append any left-over elements from VECTOR to RESULT. */
4745 gfc_constructor_append_expr (&result
->value
.constructor
,
4746 gfc_copy_expr (vector_ctor
->expr
),
4748 vector_ctor
= gfc_constructor_next (vector_ctor
);
4751 result
->shape
= gfc_get_shape (1);
4752 gfc_array_size (result
, &result
->shape
[0]);
4754 if (array
->ts
.type
== BT_CHARACTER
)
4755 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
4762 do_xor (gfc_expr
*result
, gfc_expr
*e
)
4764 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
4765 gcc_assert (result
->ts
.type
== BT_LOGICAL
4766 && result
->expr_type
== EXPR_CONSTANT
);
4768 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
4775 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
4777 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
4782 gfc_simplify_popcnt (gfc_expr
*e
)
4787 if (e
->expr_type
!= EXPR_CONSTANT
)
4790 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4792 /* Convert argument to unsigned, then count the '1' bits. */
4793 mpz_init_set (x
, e
->value
.integer
);
4794 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
4795 res
= mpz_popcount (x
);
4798 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
4803 gfc_simplify_poppar (gfc_expr
*e
)
4809 if (e
->expr_type
!= EXPR_CONSTANT
)
4812 popcnt
= gfc_simplify_popcnt (e
);
4813 gcc_assert (popcnt
);
4815 s
= gfc_extract_int (popcnt
, &i
);
4818 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
4823 gfc_simplify_precision (gfc_expr
*e
)
4825 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4826 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
4827 gfc_real_kinds
[i
].precision
);
4832 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
4834 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
4839 gfc_simplify_radix (gfc_expr
*e
)
4842 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4847 i
= gfc_integer_kinds
[i
].radix
;
4851 i
= gfc_real_kinds
[i
].radix
;
4858 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4863 gfc_simplify_range (gfc_expr
*e
)
4866 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4871 i
= gfc_integer_kinds
[i
].range
;
4876 i
= gfc_real_kinds
[i
].range
;
4883 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4888 gfc_simplify_rank (gfc_expr
*e
)
4894 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
4899 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
4901 gfc_expr
*result
= NULL
;
4904 if (e
->ts
.type
== BT_COMPLEX
)
4905 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
4907 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
4910 return &gfc_bad_expr
;
4912 if (e
->expr_type
!= EXPR_CONSTANT
)
4915 if (convert_boz (e
, kind
) == &gfc_bad_expr
)
4916 return &gfc_bad_expr
;
4918 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
4919 if (result
== &gfc_bad_expr
)
4920 return &gfc_bad_expr
;
4922 return range_check (result
, "REAL");
4927 gfc_simplify_realpart (gfc_expr
*e
)
4931 if (e
->expr_type
!= EXPR_CONSTANT
)
4934 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
4935 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
4937 return range_check (result
, "REALPART");
4941 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
4944 int i
, j
, len
, ncop
, nlen
;
4946 bool have_length
= false;
4948 /* If NCOPIES isn't a constant, there's nothing we can do. */
4949 if (n
->expr_type
!= EXPR_CONSTANT
)
4952 /* If NCOPIES is negative, it's an error. */
4953 if (mpz_sgn (n
->value
.integer
) < 0)
4955 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4957 return &gfc_bad_expr
;
4960 /* If we don't know the character length, we can do no more. */
4961 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
4962 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4964 len
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
4967 else if (e
->expr_type
== EXPR_CONSTANT
4968 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
4970 len
= e
->value
.character
.length
;
4975 /* If the source length is 0, any value of NCOPIES is valid
4976 and everything behaves as if NCOPIES == 0. */
4979 mpz_set_ui (ncopies
, 0);
4981 mpz_set (ncopies
, n
->value
.integer
);
4983 /* Check that NCOPIES isn't too large. */
4989 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
4991 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4995 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
4996 e
->ts
.u
.cl
->length
->value
.integer
);
5000 mpz_init_set_si (mlen
, len
);
5001 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
5005 /* The check itself. */
5006 if (mpz_cmp (ncopies
, max
) > 0)
5009 mpz_clear (ncopies
);
5010 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
5012 return &gfc_bad_expr
;
5017 mpz_clear (ncopies
);
5019 /* For further simplification, we need the character string to be
5021 if (e
->expr_type
!= EXPR_CONSTANT
)
5025 (e
->ts
.u
.cl
->length
&&
5026 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
)) != 0)
5028 const char *res
= gfc_extract_int (n
, &ncop
);
5029 gcc_assert (res
== NULL
);
5035 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
5037 len
= e
->value
.character
.length
;
5040 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
5041 for (i
= 0; i
< ncop
; i
++)
5042 for (j
= 0; j
< len
; j
++)
5043 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
5045 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
5050 /* This one is a bear, but mainly has to do with shuffling elements. */
5053 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
5054 gfc_expr
*pad
, gfc_expr
*order_exp
)
5056 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
5057 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
5061 gfc_expr
*e
, *result
;
5063 /* Check that argument expression types are OK. */
5064 if (!is_constant_array_expr (source
)
5065 || !is_constant_array_expr (shape_exp
)
5066 || !is_constant_array_expr (pad
)
5067 || !is_constant_array_expr (order_exp
))
5070 /* Proceed with simplification, unpacking the array. */
5077 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
5081 gfc_extract_int (e
, &shape
[rank
]);
5083 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
5084 gcc_assert (shape
[rank
] >= 0);
5089 gcc_assert (rank
> 0);
5091 /* Now unpack the order array if present. */
5092 if (order_exp
== NULL
)
5094 for (i
= 0; i
< rank
; i
++)
5099 for (i
= 0; i
< rank
; i
++)
5102 for (i
= 0; i
< rank
; i
++)
5104 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
5107 gfc_extract_int (e
, &order
[i
]);
5109 gcc_assert (order
[i
] >= 1 && order
[i
] <= rank
);
5111 gcc_assert (x
[order
[i
]] == 0);
5116 /* Count the elements in the source and padding arrays. */
5121 gfc_array_size (pad
, &size
);
5122 npad
= mpz_get_ui (size
);
5126 gfc_array_size (source
, &size
);
5127 nsource
= mpz_get_ui (size
);
5130 /* If it weren't for that pesky permutation we could just loop
5131 through the source and round out any shortage with pad elements.
5132 But no, someone just had to have the compiler do something the
5133 user should be doing. */
5135 for (i
= 0; i
< rank
; i
++)
5138 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
5140 if (source
->ts
.type
== BT_DERIVED
)
5141 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
5142 result
->rank
= rank
;
5143 result
->shape
= gfc_get_shape (rank
);
5144 for (i
= 0; i
< rank
; i
++)
5145 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
5147 while (nsource
> 0 || npad
> 0)
5149 /* Figure out which element to extract. */
5150 mpz_set_ui (index
, 0);
5152 for (i
= rank
- 1; i
>= 0; i
--)
5154 mpz_add_ui (index
, index
, x
[order
[i
]]);
5156 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
5159 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
5160 gfc_internal_error ("Reshaped array too large at %C");
5162 j
= mpz_get_ui (index
);
5165 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
5168 gcc_assert (npad
> 0);
5172 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
5176 gfc_constructor_append_expr (&result
->value
.constructor
,
5177 gfc_copy_expr (e
), &e
->where
);
5179 /* Calculate the next element. */
5183 if (++x
[i
] < shape
[i
])
5199 gfc_simplify_rrspacing (gfc_expr
*x
)
5205 if (x
->expr_type
!= EXPR_CONSTANT
)
5208 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5210 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5212 /* RRSPACING(+/- 0.0) = 0.0 */
5213 if (mpfr_zero_p (x
->value
.real
))
5215 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5219 /* RRSPACING(inf) = NaN */
5220 if (mpfr_inf_p (x
->value
.real
))
5222 mpfr_set_nan (result
->value
.real
);
5226 /* RRSPACING(NaN) = same NaN */
5227 if (mpfr_nan_p (x
->value
.real
))
5229 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5233 /* | x * 2**(-e) | * 2**p. */
5234 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5235 e
= - (long int) mpfr_get_exp (x
->value
.real
);
5236 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
5238 p
= (long int) gfc_real_kinds
[i
].digits
;
5239 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
5241 return range_check (result
, "RRSPACING");
5246 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
5248 int k
, neg_flag
, power
, exp_range
;
5249 mpfr_t scale
, radix
;
5252 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5255 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5257 if (mpfr_zero_p (x
->value
.real
))
5259 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5263 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5265 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
5267 /* This check filters out values of i that would overflow an int. */
5268 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
5269 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
5271 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
5272 gfc_free_expr (result
);
5273 return &gfc_bad_expr
;
5276 /* Compute scale = radix ** power. */
5277 power
= mpz_get_si (i
->value
.integer
);
5287 gfc_set_model_kind (x
->ts
.kind
);
5290 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
5291 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
5294 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5296 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5298 mpfr_clears (scale
, radix
, NULL
);
5300 return range_check (result
, "SCALE");
5304 /* Variants of strspn and strcspn that operate on wide characters. */
5307 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5310 const gfc_char_t
*c
;
5314 for (c
= s2
; *c
; c
++)
5328 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5331 const gfc_char_t
*c
;
5335 for (c
= s2
; *c
; c
++)
5350 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
5355 size_t indx
, len
, lenc
;
5356 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
5359 return &gfc_bad_expr
;
5361 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
5362 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
5365 if (b
!= NULL
&& b
->value
.logical
!= 0)
5370 len
= e
->value
.character
.length
;
5371 lenc
= c
->value
.character
.length
;
5373 if (len
== 0 || lenc
== 0)
5381 indx
= wide_strcspn (e
->value
.character
.string
,
5382 c
->value
.character
.string
) + 1;
5389 for (indx
= len
; indx
> 0; indx
--)
5391 for (i
= 0; i
< lenc
; i
++)
5393 if (c
->value
.character
.string
[i
]
5394 == e
->value
.character
.string
[indx
- 1])
5403 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
5404 return range_check (result
, "SCAN");
5409 gfc_simplify_selected_char_kind (gfc_expr
*e
)
5413 if (e
->expr_type
!= EXPR_CONSTANT
)
5416 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
5417 || gfc_compare_with_Cstring (e
, "default", false) == 0)
5419 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
5424 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5429 gfc_simplify_selected_int_kind (gfc_expr
*e
)
5433 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
5438 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
5439 if (gfc_integer_kinds
[i
].range
>= range
5440 && gfc_integer_kinds
[i
].kind
< kind
)
5441 kind
= gfc_integer_kinds
[i
].kind
;
5443 if (kind
== INT_MAX
)
5446 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5451 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
5453 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
5455 locus
*loc
= &gfc_current_locus
;
5461 if (p
->expr_type
!= EXPR_CONSTANT
5462 || gfc_extract_int (p
, &precision
) != NULL
)
5471 if (q
->expr_type
!= EXPR_CONSTANT
5472 || gfc_extract_int (q
, &range
) != NULL
)
5483 if (rdx
->expr_type
!= EXPR_CONSTANT
5484 || gfc_extract_int (rdx
, &radix
) != NULL
)
5492 found_precision
= 0;
5496 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5498 if (gfc_real_kinds
[i
].precision
>= precision
)
5499 found_precision
= 1;
5501 if (gfc_real_kinds
[i
].range
>= range
)
5504 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5507 if (gfc_real_kinds
[i
].precision
>= precision
5508 && gfc_real_kinds
[i
].range
>= range
5509 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5510 && gfc_real_kinds
[i
].kind
< kind
)
5511 kind
= gfc_real_kinds
[i
].kind
;
5514 if (kind
== INT_MAX
)
5516 if (found_radix
&& found_range
&& !found_precision
)
5518 else if (found_radix
&& found_precision
&& !found_range
)
5520 else if (found_radix
&& !found_precision
&& !found_range
)
5522 else if (found_radix
)
5528 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
5533 gfc_simplify_ieee_selected_real_kind (gfc_expr
*expr
)
5535 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
5536 gfc_expr
*p
= arg
->expr
, *r
= arg
->next
->expr
,
5537 *rad
= arg
->next
->next
->expr
;
5538 int precision
, range
, radix
, res
;
5539 int found_precision
, found_range
, found_radix
, i
;
5543 if (p
->expr_type
!= EXPR_CONSTANT
5544 || gfc_extract_int (p
, &precision
) != NULL
)
5552 if (r
->expr_type
!= EXPR_CONSTANT
5553 || gfc_extract_int (r
, &range
) != NULL
)
5561 if (rad
->expr_type
!= EXPR_CONSTANT
5562 || gfc_extract_int (rad
, &radix
) != NULL
)
5569 found_precision
= 0;
5573 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5575 /* We only support the target's float and double types. */
5576 if (!gfc_real_kinds
[i
].c_float
&& !gfc_real_kinds
[i
].c_double
)
5579 if (gfc_real_kinds
[i
].precision
>= precision
)
5580 found_precision
= 1;
5582 if (gfc_real_kinds
[i
].range
>= range
)
5585 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5588 if (gfc_real_kinds
[i
].precision
>= precision
5589 && gfc_real_kinds
[i
].range
>= range
5590 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5591 && gfc_real_kinds
[i
].kind
< res
)
5592 res
= gfc_real_kinds
[i
].kind
;
5597 if (found_radix
&& found_range
&& !found_precision
)
5599 else if (found_radix
&& found_precision
&& !found_range
)
5601 else if (found_radix
&& !found_precision
&& !found_range
)
5603 else if (found_radix
)
5609 return gfc_get_int_expr (gfc_default_integer_kind
, &expr
->where
, res
);
5614 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5617 mpfr_t exp
, absv
, log2
, pow2
, frac
;
5620 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5623 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5625 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
5626 SET_EXPONENT (NaN) = same NaN */
5627 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
5629 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5633 /* SET_EXPONENT (inf) = NaN */
5634 if (mpfr_inf_p (x
->value
.real
))
5636 mpfr_set_nan (result
->value
.real
);
5640 gfc_set_model_kind (x
->ts
.kind
);
5647 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
5648 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
5650 mpfr_trunc (log2
, log2
);
5651 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
5653 /* Old exponent value, and fraction. */
5654 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
5656 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
5659 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
5660 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
5662 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
5664 return range_check (result
, "SET_EXPONENT");
5669 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
5671 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5672 gfc_expr
*result
, *e
, *f
;
5676 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
5678 if (source
->rank
== -1)
5681 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
5683 if (source
->rank
== 0)
5686 if (source
->expr_type
== EXPR_VARIABLE
)
5688 ar
= gfc_find_array_ref (source
);
5689 t
= gfc_array_ref_shape (ar
, shape
);
5691 else if (source
->shape
)
5694 for (n
= 0; n
< source
->rank
; n
++)
5696 mpz_init (shape
[n
]);
5697 mpz_set (shape
[n
], source
->shape
[n
]);
5703 for (n
= 0; n
< source
->rank
; n
++)
5705 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
5708 mpz_set (e
->value
.integer
, shape
[n
]);
5711 mpz_set_ui (e
->value
.integer
, n
+ 1);
5713 f
= simplify_size (source
, e
, k
);
5717 gfc_free_expr (result
);
5724 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
5726 gfc_free_expr (result
);
5728 gfc_clear_shape (shape
, source
->rank
);
5729 return &gfc_bad_expr
;
5732 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
5736 gfc_clear_shape (shape
, source
->rank
);
5743 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
5746 gfc_expr
*return_value
;
5749 /* For unary operations, the size of the result is given by the size
5750 of the operand. For binary ones, it's the size of the first operand
5751 unless it is scalar, then it is the size of the second. */
5752 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
5754 gfc_expr
* replacement
;
5755 gfc_expr
* simplified
;
5757 switch (array
->value
.op
.op
)
5759 /* Unary operations. */
5761 case INTRINSIC_UPLUS
:
5762 case INTRINSIC_UMINUS
:
5763 case INTRINSIC_PARENTHESES
:
5764 replacement
= array
->value
.op
.op1
;
5767 /* Binary operations. If any one of the operands is scalar, take
5768 the other one's size. If both of them are arrays, it does not
5769 matter -- try to find one with known shape, if possible. */
5771 if (array
->value
.op
.op1
->rank
== 0)
5772 replacement
= array
->value
.op
.op2
;
5773 else if (array
->value
.op
.op2
->rank
== 0)
5774 replacement
= array
->value
.op
.op1
;
5777 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
5781 replacement
= array
->value
.op
.op2
;
5786 /* Try to reduce it directly if possible. */
5787 simplified
= simplify_size (replacement
, dim
, k
);
5789 /* Otherwise, we build a new SIZE call. This is hopefully at least
5790 simpler than the original one. */
5793 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
5794 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
5795 GFC_ISYM_SIZE
, "size",
5797 gfc_copy_expr (replacement
),
5798 gfc_copy_expr (dim
),
5806 if (!gfc_array_size (array
, &size
))
5811 if (dim
->expr_type
!= EXPR_CONSTANT
)
5814 d
= mpz_get_ui (dim
->value
.integer
) - 1;
5815 if (!gfc_array_dimen_size (array
, d
, &size
))
5819 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
5820 mpz_set (return_value
->value
.integer
, size
);
5823 return return_value
;
5828 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5831 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
5834 return &gfc_bad_expr
;
5836 result
= simplify_size (array
, dim
, k
);
5837 if (result
== NULL
|| result
== &gfc_bad_expr
)
5840 return range_check (result
, "SIZE");
5844 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
5845 multiplied by the array size. */
5848 gfc_simplify_sizeof (gfc_expr
*x
)
5850 gfc_expr
*result
= NULL
;
5853 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
5856 if (x
->ts
.type
== BT_CHARACTER
5857 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
5858 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
5861 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
5862 && !gfc_array_size (x
, &array_size
))
5865 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
5867 mpz_set_si (result
->value
.integer
, gfc_target_expr_size (x
));
5873 /* STORAGE_SIZE returns the size in bits of a single array element. */
5876 gfc_simplify_storage_size (gfc_expr
*x
,
5879 gfc_expr
*result
= NULL
;
5882 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
5885 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
5886 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
5887 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
5890 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
5892 return &gfc_bad_expr
;
5894 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
5896 mpz_set_si (result
->value
.integer
, gfc_element_size (x
));
5897 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
5899 return range_check (result
, "STORAGE_SIZE");
5904 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
5908 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
5911 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5916 mpz_abs (result
->value
.integer
, x
->value
.integer
);
5917 if (mpz_sgn (y
->value
.integer
) < 0)
5918 mpz_neg (result
->value
.integer
, result
->value
.integer
);
5922 if (gfc_option
.flag_sign_zero
)
5923 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
5926 mpfr_setsign (result
->value
.real
, x
->value
.real
,
5927 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
5931 gfc_internal_error ("Bad type in gfc_simplify_sign");
5939 gfc_simplify_sin (gfc_expr
*x
)
5943 if (x
->expr_type
!= EXPR_CONSTANT
)
5946 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5951 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5955 gfc_set_model (x
->value
.real
);
5956 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5960 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5963 return range_check (result
, "SIN");
5968 gfc_simplify_sinh (gfc_expr
*x
)
5972 if (x
->expr_type
!= EXPR_CONSTANT
)
5975 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5980 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5984 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5991 return range_check (result
, "SINH");
5995 /* The argument is always a double precision real that is converted to
5996 single precision. TODO: Rounding! */
5999 gfc_simplify_sngl (gfc_expr
*a
)
6003 if (a
->expr_type
!= EXPR_CONSTANT
)
6006 result
= gfc_real2real (a
, gfc_default_real_kind
);
6007 return range_check (result
, "SNGL");
6012 gfc_simplify_spacing (gfc_expr
*x
)
6018 if (x
->expr_type
!= EXPR_CONSTANT
)
6021 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
6022 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
6024 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
6025 if (mpfr_zero_p (x
->value
.real
))
6027 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6031 /* SPACING(inf) = NaN */
6032 if (mpfr_inf_p (x
->value
.real
))
6034 mpfr_set_nan (result
->value
.real
);
6038 /* SPACING(NaN) = same NaN */
6039 if (mpfr_nan_p (x
->value
.real
))
6041 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6045 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
6046 are the radix, exponent of x, and precision. This excludes the
6047 possibility of subnormal numbers. Fortran 2003 states the result is
6048 b**max(e - p, emin - 1). */
6050 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
6051 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
6052 en
= en
> ep
? en
: ep
;
6054 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
6055 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
6057 return range_check (result
, "SPACING");
6062 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
6064 gfc_expr
*result
= 0L;
6065 int i
, j
, dim
, ncopies
;
6068 if ((!gfc_is_constant_expr (source
)
6069 && !is_constant_array_expr (source
))
6070 || !gfc_is_constant_expr (dim_expr
)
6071 || !gfc_is_constant_expr (ncopies_expr
))
6074 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
6075 gfc_extract_int (dim_expr
, &dim
);
6076 dim
-= 1; /* zero-base DIM */
6078 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
6079 gfc_extract_int (ncopies_expr
, &ncopies
);
6080 ncopies
= MAX (ncopies
, 0);
6082 /* Do not allow the array size to exceed the limit for an array
6084 if (source
->expr_type
== EXPR_ARRAY
)
6086 if (!gfc_array_size (source
, &size
))
6087 gfc_internal_error ("Failure getting length of a constant array.");
6090 mpz_init_set_ui (size
, 1);
6092 if (mpz_get_si (size
)*ncopies
> gfc_option
.flag_max_array_constructor
)
6095 if (source
->expr_type
== EXPR_CONSTANT
)
6097 gcc_assert (dim
== 0);
6099 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6101 if (source
->ts
.type
== BT_DERIVED
)
6102 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6104 result
->shape
= gfc_get_shape (result
->rank
);
6105 mpz_init_set_si (result
->shape
[0], ncopies
);
6107 for (i
= 0; i
< ncopies
; ++i
)
6108 gfc_constructor_append_expr (&result
->value
.constructor
,
6109 gfc_copy_expr (source
), NULL
);
6111 else if (source
->expr_type
== EXPR_ARRAY
)
6113 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
6114 gfc_constructor
*source_ctor
;
6116 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
6117 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
6119 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6121 if (source
->ts
.type
== BT_DERIVED
)
6122 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6123 result
->rank
= source
->rank
+ 1;
6124 result
->shape
= gfc_get_shape (result
->rank
);
6126 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
6129 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
6131 mpz_init_set_si (result
->shape
[i
], ncopies
);
6133 extent
[i
] = mpz_get_si (result
->shape
[i
]);
6134 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
6138 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
6139 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
6141 for (i
= 0; i
< ncopies
; ++i
)
6142 gfc_constructor_insert_expr (&result
->value
.constructor
,
6143 gfc_copy_expr (source_ctor
->expr
),
6144 NULL
, offset
+ i
* rstride
[dim
]);
6146 offset
+= (dim
== 0 ? ncopies
: 1);
6150 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
6151 Replace NULL with gcc_unreachable() after implementing
6152 gfc_simplify_cshift(). */
6155 if (source
->ts
.type
== BT_CHARACTER
)
6156 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
6163 gfc_simplify_sqrt (gfc_expr
*e
)
6165 gfc_expr
*result
= NULL
;
6167 if (e
->expr_type
!= EXPR_CONSTANT
)
6173 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
6175 gfc_error ("Argument of SQRT at %L has a negative value",
6177 return &gfc_bad_expr
;
6179 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6180 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6184 gfc_set_model (e
->value
.real
);
6186 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6187 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
6191 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
6194 return range_check (result
, "SQRT");
6199 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6201 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
6206 gfc_simplify_tan (gfc_expr
*x
)
6210 if (x
->expr_type
!= EXPR_CONSTANT
)
6213 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6218 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6222 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6229 return range_check (result
, "TAN");
6234 gfc_simplify_tanh (gfc_expr
*x
)
6238 if (x
->expr_type
!= EXPR_CONSTANT
)
6241 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6246 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6250 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6257 return range_check (result
, "TANH");
6262 gfc_simplify_tiny (gfc_expr
*e
)
6267 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
6269 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6270 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6277 gfc_simplify_trailz (gfc_expr
*e
)
6279 unsigned long tz
, bs
;
6282 if (e
->expr_type
!= EXPR_CONSTANT
)
6285 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6286 bs
= gfc_integer_kinds
[i
].bit_size
;
6287 tz
= mpz_scan1 (e
->value
.integer
, 0);
6289 return gfc_get_int_expr (gfc_default_integer_kind
,
6290 &e
->where
, MIN (tz
, bs
));
6295 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6298 gfc_expr
*mold_element
;
6303 unsigned char *buffer
;
6304 size_t result_length
;
6307 if (!gfc_is_constant_expr (source
)
6308 || (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
6309 || !gfc_is_constant_expr (size
))
6312 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6313 &result_size
, &result_length
))
6316 /* Calculate the size of the source. */
6317 if (source
->expr_type
== EXPR_ARRAY
6318 && !gfc_array_size (source
, &tmp
))
6319 gfc_internal_error ("Failure getting length of a constant array.");
6321 /* Create an empty new expression with the appropriate characteristics. */
6322 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
6324 result
->ts
= mold
->ts
;
6326 mold_element
= mold
->expr_type
== EXPR_ARRAY
6327 ? gfc_constructor_first (mold
->value
.constructor
)->expr
6330 /* Set result character length, if needed. Note that this needs to be
6331 set even for array expressions, in order to pass this information into
6332 gfc_target_interpret_expr. */
6333 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
6334 result
->value
.character
.length
= mold_element
->value
.character
.length
;
6336 /* Set the number of elements in the result, and determine its size. */
6338 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
6340 result
->expr_type
= EXPR_ARRAY
;
6342 result
->shape
= gfc_get_shape (1);
6343 mpz_init_set_ui (result
->shape
[0], result_length
);
6348 /* Allocate the buffer to store the binary version of the source. */
6349 buffer_size
= MAX (source_size
, result_size
);
6350 buffer
= (unsigned char*)alloca (buffer_size
);
6351 memset (buffer
, 0, buffer_size
);
6353 /* Now write source to the buffer. */
6354 gfc_target_encode_expr (source
, buffer
, buffer_size
);
6356 /* And read the buffer back into the new expression. */
6357 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
6364 gfc_simplify_transpose (gfc_expr
*matrix
)
6366 int row
, matrix_rows
, col
, matrix_cols
;
6369 if (!is_constant_array_expr (matrix
))
6372 gcc_assert (matrix
->rank
== 2);
6374 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
6377 result
->shape
= gfc_get_shape (result
->rank
);
6378 mpz_set (result
->shape
[0], matrix
->shape
[1]);
6379 mpz_set (result
->shape
[1], matrix
->shape
[0]);
6381 if (matrix
->ts
.type
== BT_CHARACTER
)
6382 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
6383 else if (matrix
->ts
.type
== BT_DERIVED
)
6384 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
6386 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
6387 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
6388 for (row
= 0; row
< matrix_rows
; ++row
)
6389 for (col
= 0; col
< matrix_cols
; ++col
)
6391 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
6392 col
* matrix_rows
+ row
);
6393 gfc_constructor_insert_expr (&result
->value
.constructor
,
6394 gfc_copy_expr (e
), &matrix
->where
,
6395 row
* matrix_cols
+ col
);
6403 gfc_simplify_trim (gfc_expr
*e
)
6406 int count
, i
, len
, lentrim
;
6408 if (e
->expr_type
!= EXPR_CONSTANT
)
6411 len
= e
->value
.character
.length
;
6412 for (count
= 0, i
= 1; i
<= len
; ++i
)
6414 if (e
->value
.character
.string
[len
- i
] == ' ')
6420 lentrim
= len
- count
;
6422 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
6423 for (i
= 0; i
< lentrim
; i
++)
6424 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
6431 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
6436 gfc_constructor
*sub_cons
;
6440 if (!is_constant_array_expr (sub
))
6443 /* Follow any component references. */
6444 as
= coarray
->symtree
->n
.sym
->as
;
6445 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
6446 if (ref
->type
== REF_COMPONENT
)
6449 if (as
->type
== AS_DEFERRED
)
6452 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6453 the cosubscript addresses the first image. */
6455 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
6458 for (d
= 1; d
<= as
->corank
; d
++)
6463 gcc_assert (sub_cons
!= NULL
);
6465 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
6467 if (ca_bound
== NULL
)
6470 if (ca_bound
== &gfc_bad_expr
)
6473 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
6477 gfc_free_expr (ca_bound
);
6478 sub_cons
= gfc_constructor_next (sub_cons
);
6482 first_image
= false;
6486 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6487 "SUB has %ld and COARRAY lower bound is %ld)",
6489 mpz_get_si (sub_cons
->expr
->value
.integer
),
6490 mpz_get_si (ca_bound
->value
.integer
));
6491 gfc_free_expr (ca_bound
);
6492 return &gfc_bad_expr
;
6495 gfc_free_expr (ca_bound
);
6497 /* Check whether upperbound is valid for the multi-images case. */
6500 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
6502 if (ca_bound
== &gfc_bad_expr
)
6505 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
6506 && mpz_cmp (ca_bound
->value
.integer
,
6507 sub_cons
->expr
->value
.integer
) < 0)
6509 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6510 "SUB has %ld and COARRAY upper bound is %ld)",
6512 mpz_get_si (sub_cons
->expr
->value
.integer
),
6513 mpz_get_si (ca_bound
->value
.integer
));
6514 gfc_free_expr (ca_bound
);
6515 return &gfc_bad_expr
;
6519 gfc_free_expr (ca_bound
);
6522 sub_cons
= gfc_constructor_next (sub_cons
);
6525 gcc_assert (sub_cons
== NULL
);
6527 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
6530 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6531 &gfc_current_locus
);
6533 mpz_set_si (result
->value
.integer
, 1);
6535 mpz_set_si (result
->value
.integer
, 0);
6542 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
6543 gfc_expr
*distance ATTRIBUTE_UNUSED
)
6545 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
6548 /* If no coarray argument has been passed or when the first argument
6549 is actually a distance argment. */
6550 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
6553 /* FIXME: gfc_current_locus is wrong. */
6554 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6555 &gfc_current_locus
);
6556 mpz_set_si (result
->value
.integer
, 1);
6560 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
6561 return simplify_cobound (coarray
, dim
, NULL
, 0);
6566 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6568 return simplify_bound (array
, dim
, kind
, 1);
6572 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6574 return simplify_cobound (array
, dim
, kind
, 1);
6579 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6581 gfc_expr
*result
, *e
;
6582 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
6584 if (!is_constant_array_expr (vector
)
6585 || !is_constant_array_expr (mask
)
6586 || (!gfc_is_constant_expr (field
)
6587 && !is_constant_array_expr (field
)))
6590 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
6592 if (vector
->ts
.type
== BT_DERIVED
)
6593 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
6594 result
->rank
= mask
->rank
;
6595 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
6597 if (vector
->ts
.type
== BT_CHARACTER
)
6598 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
6600 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
6601 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6603 = field
->expr_type
== EXPR_ARRAY
6604 ? gfc_constructor_first (field
->value
.constructor
)
6609 if (mask_ctor
->expr
->value
.logical
)
6611 gcc_assert (vector_ctor
);
6612 e
= gfc_copy_expr (vector_ctor
->expr
);
6613 vector_ctor
= gfc_constructor_next (vector_ctor
);
6615 else if (field
->expr_type
== EXPR_ARRAY
)
6616 e
= gfc_copy_expr (field_ctor
->expr
);
6618 e
= gfc_copy_expr (field
);
6620 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
6622 mask_ctor
= gfc_constructor_next (mask_ctor
);
6623 field_ctor
= gfc_constructor_next (field_ctor
);
6631 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
6635 size_t index
, len
, lenset
;
6637 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
6640 return &gfc_bad_expr
;
6642 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
6643 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
6646 if (b
!= NULL
&& b
->value
.logical
!= 0)
6651 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
6653 len
= s
->value
.character
.length
;
6654 lenset
= set
->value
.character
.length
;
6658 mpz_set_ui (result
->value
.integer
, 0);
6666 mpz_set_ui (result
->value
.integer
, 1);
6670 index
= wide_strspn (s
->value
.character
.string
,
6671 set
->value
.character
.string
) + 1;
6680 mpz_set_ui (result
->value
.integer
, len
);
6683 for (index
= len
; index
> 0; index
--)
6685 for (i
= 0; i
< lenset
; i
++)
6687 if (s
->value
.character
.string
[index
- 1]
6688 == set
->value
.character
.string
[i
])
6696 mpz_set_ui (result
->value
.integer
, index
);
6702 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
6707 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6710 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6715 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6716 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6717 return range_check (result
, "XOR");
6720 return gfc_get_logical_expr (kind
, &x
->where
,
6721 (x
->value
.logical
&& !y
->value
.logical
)
6722 || (!x
->value
.logical
&& y
->value
.logical
));
6730 /****************** Constant simplification *****************/
6732 /* Master function to convert one constant to another. While this is
6733 used as a simplification function, it requires the destination type
6734 and kind information which is supplied by a special case in
6738 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
6740 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
6755 f
= gfc_int2complex
;
6775 f
= gfc_real2complex
;
6786 f
= gfc_complex2int
;
6789 f
= gfc_complex2real
;
6792 f
= gfc_complex2complex
;
6818 f
= gfc_hollerith2int
;
6822 f
= gfc_hollerith2real
;
6826 f
= gfc_hollerith2complex
;
6830 f
= gfc_hollerith2character
;
6834 f
= gfc_hollerith2logical
;
6844 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6849 switch (e
->expr_type
)
6852 result
= f (e
, kind
);
6854 return &gfc_bad_expr
;
6858 if (!gfc_is_constant_expr (e
))
6861 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6862 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6863 result
->rank
= e
->rank
;
6865 for (c
= gfc_constructor_first (e
->value
.constructor
);
6866 c
; c
= gfc_constructor_next (c
))
6869 if (c
->iterator
== NULL
)
6870 tmp
= f (c
->expr
, kind
);
6873 g
= gfc_convert_constant (c
->expr
, type
, kind
);
6874 if (g
== &gfc_bad_expr
)
6876 gfc_free_expr (result
);
6884 gfc_free_expr (result
);
6888 gfc_constructor_append_expr (&result
->value
.constructor
,
6902 /* Function for converting character constants. */
6904 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
6909 if (!gfc_is_constant_expr (e
))
6912 if (e
->expr_type
== EXPR_CONSTANT
)
6914 /* Simple case of a scalar. */
6915 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
6917 return &gfc_bad_expr
;
6919 result
->value
.character
.length
= e
->value
.character
.length
;
6920 result
->value
.character
.string
6921 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
6922 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
6923 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
6925 /* Check we only have values representable in the destination kind. */
6926 for (i
= 0; i
< result
->value
.character
.length
; i
++)
6927 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
6930 gfc_error ("Character '%s' in string at %L cannot be converted "
6931 "into character kind %d",
6932 gfc_print_wide_char (result
->value
.character
.string
[i
]),
6934 return &gfc_bad_expr
;
6939 else if (e
->expr_type
== EXPR_ARRAY
)
6941 /* For an array constructor, we convert each constructor element. */
6944 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6945 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6946 result
->rank
= e
->rank
;
6947 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
6949 for (c
= gfc_constructor_first (e
->value
.constructor
);
6950 c
; c
= gfc_constructor_next (c
))
6952 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
6953 if (tmp
== &gfc_bad_expr
)
6955 gfc_free_expr (result
);
6956 return &gfc_bad_expr
;
6961 gfc_free_expr (result
);
6965 gfc_constructor_append_expr (&result
->value
.constructor
,
6977 gfc_simplify_compiler_options (void)
6982 str
= gfc_get_option_string ();
6983 result
= gfc_get_character_expr (gfc_default_character_kind
,
6984 &gfc_current_locus
, str
, strlen (str
));
6991 gfc_simplify_compiler_version (void)
6996 len
= strlen ("GCC version ") + strlen (version_string
);
6997 buffer
= XALLOCAVEC (char, len
+ 1);
6998 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
6999 return gfc_get_character_expr (gfc_default_character_kind
,
7000 &gfc_current_locus
, buffer
, len
);