1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2015 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 (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 (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
&& warn_surprising
&& mpz_cmp_si (e
->value
.integer
, 127) > 0)
719 gfc_warning (OPT_Wsurprising
,
720 "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
&& 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
&& !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 (warn_surprising
&& index
> 127)
2509 gfc_warning (OPT_Wsurprising
,
2510 "Argument of IACHAR function at %L outside of range 0..127",
2513 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
2515 return &gfc_bad_expr
;
2517 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2519 return range_check (result
, "IACHAR");
2524 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
2526 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2527 gcc_assert (result
->ts
.type
== BT_INTEGER
2528 && result
->expr_type
== EXPR_CONSTANT
);
2530 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2536 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2538 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
2543 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
2545 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2546 gcc_assert (result
->ts
.type
== BT_INTEGER
2547 && result
->expr_type
== EXPR_CONSTANT
);
2549 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2555 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2557 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
2562 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
2566 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2569 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2570 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2572 return range_check (result
, "IAND");
2577 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
2582 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2585 gfc_extract_int (y
, &pos
);
2587 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2589 result
= gfc_copy_expr (x
);
2591 convert_mpz_to_unsigned (result
->value
.integer
,
2592 gfc_integer_kinds
[k
].bit_size
);
2594 mpz_clrbit (result
->value
.integer
, pos
);
2596 gfc_convert_mpz_to_signed (result
->value
.integer
,
2597 gfc_integer_kinds
[k
].bit_size
);
2604 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
2611 if (x
->expr_type
!= EXPR_CONSTANT
2612 || y
->expr_type
!= EXPR_CONSTANT
2613 || z
->expr_type
!= EXPR_CONSTANT
)
2616 gfc_extract_int (y
, &pos
);
2617 gfc_extract_int (z
, &len
);
2619 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
2621 bitsize
= gfc_integer_kinds
[k
].bit_size
;
2623 if (pos
+ len
> bitsize
)
2625 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2626 "bit size at %L", &y
->where
);
2627 return &gfc_bad_expr
;
2630 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2631 convert_mpz_to_unsigned (result
->value
.integer
,
2632 gfc_integer_kinds
[k
].bit_size
);
2634 bits
= XCNEWVEC (int, bitsize
);
2636 for (i
= 0; i
< bitsize
; i
++)
2639 for (i
= 0; i
< len
; i
++)
2640 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
2642 for (i
= 0; i
< bitsize
; i
++)
2645 mpz_clrbit (result
->value
.integer
, i
);
2646 else if (bits
[i
] == 1)
2647 mpz_setbit (result
->value
.integer
, i
);
2649 gfc_internal_error ("IBITS: Bad bit");
2654 gfc_convert_mpz_to_signed (result
->value
.integer
,
2655 gfc_integer_kinds
[k
].bit_size
);
2662 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
2667 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2670 gfc_extract_int (y
, &pos
);
2672 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2674 result
= gfc_copy_expr (x
);
2676 convert_mpz_to_unsigned (result
->value
.integer
,
2677 gfc_integer_kinds
[k
].bit_size
);
2679 mpz_setbit (result
->value
.integer
, pos
);
2681 gfc_convert_mpz_to_signed (result
->value
.integer
,
2682 gfc_integer_kinds
[k
].bit_size
);
2689 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
2695 if (e
->expr_type
!= EXPR_CONSTANT
)
2698 if (e
->value
.character
.length
!= 1)
2700 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
2701 return &gfc_bad_expr
;
2704 index
= e
->value
.character
.string
[0];
2706 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
2708 return &gfc_bad_expr
;
2710 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2712 return range_check (result
, "ICHAR");
2717 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
2721 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2724 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2725 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2727 return range_check (result
, "IEOR");
2732 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
2735 int back
, len
, lensub
;
2736 int i
, j
, k
, count
, index
= 0, start
;
2738 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
2739 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
2742 if (b
!= NULL
&& b
->value
.logical
!= 0)
2747 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
2749 return &gfc_bad_expr
;
2751 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
2753 len
= x
->value
.character
.length
;
2754 lensub
= y
->value
.character
.length
;
2758 mpz_set_si (result
->value
.integer
, 0);
2766 mpz_set_si (result
->value
.integer
, 1);
2769 else if (lensub
== 1)
2771 for (i
= 0; i
< len
; i
++)
2773 for (j
= 0; j
< lensub
; j
++)
2775 if (y
->value
.character
.string
[j
]
2776 == x
->value
.character
.string
[i
])
2786 for (i
= 0; i
< len
; i
++)
2788 for (j
= 0; j
< lensub
; j
++)
2790 if (y
->value
.character
.string
[j
]
2791 == x
->value
.character
.string
[i
])
2796 for (k
= 0; k
< lensub
; k
++)
2798 if (y
->value
.character
.string
[k
]
2799 == x
->value
.character
.string
[k
+ start
])
2803 if (count
== lensub
)
2818 mpz_set_si (result
->value
.integer
, len
+ 1);
2821 else if (lensub
== 1)
2823 for (i
= 0; i
< len
; i
++)
2825 for (j
= 0; j
< lensub
; j
++)
2827 if (y
->value
.character
.string
[j
]
2828 == x
->value
.character
.string
[len
- i
])
2830 index
= len
- i
+ 1;
2838 for (i
= 0; i
< len
; i
++)
2840 for (j
= 0; j
< lensub
; j
++)
2842 if (y
->value
.character
.string
[j
]
2843 == x
->value
.character
.string
[len
- i
])
2846 if (start
<= len
- lensub
)
2849 for (k
= 0; k
< lensub
; k
++)
2850 if (y
->value
.character
.string
[k
]
2851 == x
->value
.character
.string
[k
+ start
])
2854 if (count
== lensub
)
2871 mpz_set_si (result
->value
.integer
, index
);
2872 return range_check (result
, "INDEX");
2877 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
2879 gfc_expr
*result
= NULL
;
2881 if (e
->expr_type
!= EXPR_CONSTANT
)
2884 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
2885 if (result
== &gfc_bad_expr
)
2886 return &gfc_bad_expr
;
2888 return range_check (result
, name
);
2893 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
2897 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
2899 return &gfc_bad_expr
;
2901 return simplify_intconv (e
, kind
, "INT");
2905 gfc_simplify_int2 (gfc_expr
*e
)
2907 return simplify_intconv (e
, 2, "INT2");
2912 gfc_simplify_int8 (gfc_expr
*e
)
2914 return simplify_intconv (e
, 8, "INT8");
2919 gfc_simplify_long (gfc_expr
*e
)
2921 return simplify_intconv (e
, 4, "LONG");
2926 gfc_simplify_ifix (gfc_expr
*e
)
2928 gfc_expr
*rtrunc
, *result
;
2930 if (e
->expr_type
!= EXPR_CONSTANT
)
2933 rtrunc
= gfc_copy_expr (e
);
2934 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
2936 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2938 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
2940 gfc_free_expr (rtrunc
);
2942 return range_check (result
, "IFIX");
2947 gfc_simplify_idint (gfc_expr
*e
)
2949 gfc_expr
*rtrunc
, *result
;
2951 if (e
->expr_type
!= EXPR_CONSTANT
)
2954 rtrunc
= gfc_copy_expr (e
);
2955 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
2957 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2959 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
2961 gfc_free_expr (rtrunc
);
2963 return range_check (result
, "IDINT");
2968 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
2972 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2975 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2976 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2978 return range_check (result
, "IOR");
2983 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
2985 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2986 gcc_assert (result
->ts
.type
== BT_INTEGER
2987 && result
->expr_type
== EXPR_CONSTANT
);
2989 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2995 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2997 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3002 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3004 if (x
->expr_type
!= EXPR_CONSTANT
)
3007 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3008 mpz_cmp_si (x
->value
.integer
,
3009 LIBERROR_END
) == 0);
3014 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3016 if (x
->expr_type
!= EXPR_CONSTANT
)
3019 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3020 mpz_cmp_si (x
->value
.integer
,
3021 LIBERROR_EOR
) == 0);
3026 gfc_simplify_isnan (gfc_expr
*x
)
3028 if (x
->expr_type
!= EXPR_CONSTANT
)
3031 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3032 mpfr_nan_p (x
->value
.real
));
3036 /* Performs a shift on its first argument. Depending on the last
3037 argument, the shift can be arithmetic, i.e. with filling from the
3038 left like in the SHIFTA intrinsic. */
3040 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3041 bool arithmetic
, int direction
)
3044 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3046 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3049 gfc_extract_int (s
, &shift
);
3051 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3052 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3054 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3058 mpz_set (result
->value
.integer
, e
->value
.integer
);
3062 if (direction
> 0 && shift
< 0)
3064 /* Left shift, as in SHIFTL. */
3065 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3066 return &gfc_bad_expr
;
3068 else if (direction
< 0)
3070 /* Right shift, as in SHIFTR or SHIFTA. */
3073 gfc_error ("Second argument of %s is negative at %L",
3075 return &gfc_bad_expr
;
3081 ashift
= (shift
>= 0 ? shift
: -shift
);
3083 if (ashift
> bitsize
)
3085 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3086 "at %L", name
, &e
->where
);
3087 return &gfc_bad_expr
;
3090 bits
= XCNEWVEC (int, bitsize
);
3092 for (i
= 0; i
< bitsize
; i
++)
3093 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3098 for (i
= 0; i
< shift
; i
++)
3099 mpz_clrbit (result
->value
.integer
, i
);
3101 for (i
= 0; i
< bitsize
- shift
; i
++)
3104 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3106 mpz_setbit (result
->value
.integer
, i
+ shift
);
3112 if (arithmetic
&& bits
[bitsize
- 1])
3113 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3114 mpz_setbit (result
->value
.integer
, i
);
3116 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3117 mpz_clrbit (result
->value
.integer
, i
);
3119 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3122 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3124 mpz_setbit (result
->value
.integer
, i
- ashift
);
3128 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3136 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3138 return simplify_shift (e
, s
, "ISHFT", false, 0);
3143 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3145 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3150 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3152 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3157 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3159 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3164 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3166 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3171 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3173 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3178 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3181 int shift
, ashift
, isize
, ssize
, delta
, k
;
3184 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3187 gfc_extract_int (s
, &shift
);
3189 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3190 isize
= gfc_integer_kinds
[k
].bit_size
;
3194 if (sz
->expr_type
!= EXPR_CONSTANT
)
3197 gfc_extract_int (sz
, &ssize
);
3211 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3212 "BIT_SIZE of first argument at %L", &s
->where
);
3213 return &gfc_bad_expr
;
3216 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3218 mpz_set (result
->value
.integer
, e
->value
.integer
);
3223 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
3225 bits
= XCNEWVEC (int, ssize
);
3227 for (i
= 0; i
< ssize
; i
++)
3228 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3230 delta
= ssize
- ashift
;
3234 for (i
= 0; i
< delta
; i
++)
3237 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3239 mpz_setbit (result
->value
.integer
, i
+ shift
);
3242 for (i
= delta
; i
< ssize
; i
++)
3245 mpz_clrbit (result
->value
.integer
, i
- delta
);
3247 mpz_setbit (result
->value
.integer
, i
- delta
);
3252 for (i
= 0; i
< ashift
; i
++)
3255 mpz_clrbit (result
->value
.integer
, i
+ delta
);
3257 mpz_setbit (result
->value
.integer
, i
+ delta
);
3260 for (i
= ashift
; i
< ssize
; i
++)
3263 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3265 mpz_setbit (result
->value
.integer
, i
+ shift
);
3269 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
3277 gfc_simplify_kind (gfc_expr
*e
)
3279 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
3284 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
3285 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
3287 gfc_expr
*l
, *u
, *result
;
3290 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3291 gfc_default_integer_kind
);
3293 return &gfc_bad_expr
;
3295 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3297 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3298 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3299 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
3303 gfc_expr
* dim
= result
;
3304 mpz_set_si (dim
->value
.integer
, d
);
3306 result
= simplify_size (array
, dim
, k
);
3307 gfc_free_expr (dim
);
3312 mpz_set_si (result
->value
.integer
, 1);
3317 /* Otherwise, we have a variable expression. */
3318 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
3321 if (!gfc_resolve_array_spec (as
, 0))
3324 /* The last dimension of an assumed-size array is special. */
3325 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
3326 || (coarray
&& d
== as
->rank
+ as
->corank
3327 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
3329 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
3331 gfc_free_expr (result
);
3332 return gfc_copy_expr (as
->lower
[d
-1]);
3338 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3340 /* Then, we need to know the extent of the given dimension. */
3341 if (coarray
|| ref
->u
.ar
.type
== AR_FULL
)
3346 if (l
->expr_type
!= EXPR_CONSTANT
|| u
== NULL
3347 || u
->expr_type
!= EXPR_CONSTANT
)
3350 if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
3354 mpz_set_si (result
->value
.integer
, 0);
3356 mpz_set_si (result
->value
.integer
, 1);
3360 /* Nonzero extent. */
3362 mpz_set (result
->value
.integer
, u
->value
.integer
);
3364 mpz_set (result
->value
.integer
, l
->value
.integer
);
3371 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d
- 1, &result
->value
.integer
, NULL
))
3375 mpz_set_si (result
->value
.integer
, (long int) 1);
3379 return range_check (result
, upper
? "UBOUND" : "LBOUND");
3382 gfc_free_expr (result
);
3388 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3394 if (array
->ts
.type
== BT_CLASS
)
3397 if (array
->expr_type
!= EXPR_VARIABLE
)
3404 /* Follow any component references. */
3405 as
= array
->symtree
->n
.sym
->as
;
3406 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3411 switch (ref
->u
.ar
.type
)
3418 /* We're done because 'as' has already been set in the
3419 previous iteration. */
3436 as
= ref
->u
.c
.component
->as
;
3448 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
3449 || as
->type
== AS_ASSUMED_RANK
))
3454 /* Multi-dimensional bounds. */
3455 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3459 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
3460 if (upper
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
3462 /* An error message will be emitted in
3463 check_assumed_size_reference (resolve.c). */
3464 return &gfc_bad_expr
;
3467 /* Simplify the bounds for each dimension. */
3468 for (d
= 0; d
< array
->rank
; d
++)
3470 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
3472 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3476 for (j
= 0; j
< d
; j
++)
3477 gfc_free_expr (bounds
[j
]);
3482 /* Allocate the result expression. */
3483 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3484 gfc_default_integer_kind
);
3486 return &gfc_bad_expr
;
3488 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
3490 /* The result is a rank 1 array; its size is the rank of the first
3491 argument to {L,U}BOUND. */
3493 e
->shape
= gfc_get_shape (1);
3494 mpz_init_set_ui (e
->shape
[0], array
->rank
);
3496 /* Create the constructor for this array. */
3497 for (d
= 0; d
< array
->rank
; d
++)
3498 gfc_constructor_append_expr (&e
->value
.constructor
,
3499 bounds
[d
], &e
->where
);
3505 /* A DIM argument is specified. */
3506 if (dim
->expr_type
!= EXPR_CONSTANT
)
3509 d
= mpz_get_si (dim
->value
.integer
);
3511 if ((d
< 1 || d
> array
->rank
)
3512 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
3514 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3515 return &gfc_bad_expr
;
3518 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3521 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
3527 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3533 if (array
->expr_type
!= EXPR_VARIABLE
)
3536 /* Follow any component references. */
3537 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
3538 ? array
->ts
.u
.derived
->components
->as
3539 : array
->symtree
->n
.sym
->as
;
3540 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3545 switch (ref
->u
.ar
.type
)
3548 if (ref
->u
.ar
.as
->corank
> 0)
3550 gcc_assert (as
== ref
->u
.ar
.as
);
3557 /* We're done because 'as' has already been set in the
3558 previous iteration. */
3575 as
= ref
->u
.c
.component
->as
;
3588 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
3593 /* Multi-dimensional cobounds. */
3594 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3598 /* Simplify the cobounds for each dimension. */
3599 for (d
= 0; d
< as
->corank
; d
++)
3601 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
3602 upper
, as
, ref
, true);
3603 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3607 for (j
= 0; j
< d
; j
++)
3608 gfc_free_expr (bounds
[j
]);
3613 /* Allocate the result expression. */
3614 e
= gfc_get_expr ();
3615 e
->where
= array
->where
;
3616 e
->expr_type
= EXPR_ARRAY
;
3617 e
->ts
.type
= BT_INTEGER
;
3618 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
3619 gfc_default_integer_kind
);
3623 return &gfc_bad_expr
;
3627 /* The result is a rank 1 array; its size is the rank of the first
3628 argument to {L,U}COBOUND. */
3630 e
->shape
= gfc_get_shape (1);
3631 mpz_init_set_ui (e
->shape
[0], as
->corank
);
3633 /* Create the constructor for this array. */
3634 for (d
= 0; d
< as
->corank
; d
++)
3635 gfc_constructor_append_expr (&e
->value
.constructor
,
3636 bounds
[d
], &e
->where
);
3641 /* A DIM argument is specified. */
3642 if (dim
->expr_type
!= EXPR_CONSTANT
)
3645 d
= mpz_get_si (dim
->value
.integer
);
3647 if (d
< 1 || d
> as
->corank
)
3649 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3650 return &gfc_bad_expr
;
3653 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
3659 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3661 return simplify_bound (array
, dim
, kind
, 0);
3666 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3668 return simplify_cobound (array
, dim
, kind
, 0);
3672 gfc_simplify_leadz (gfc_expr
*e
)
3674 unsigned long lz
, bs
;
3677 if (e
->expr_type
!= EXPR_CONSTANT
)
3680 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3681 bs
= gfc_integer_kinds
[i
].bit_size
;
3682 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
3684 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
3687 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
3689 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
3694 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
3697 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
3700 return &gfc_bad_expr
;
3702 if (e
->expr_type
== EXPR_CONSTANT
)
3704 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3705 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
3706 return range_check (result
, "LEN");
3708 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
3709 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3710 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
3712 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3713 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
3714 return range_check (result
, "LEN");
3716 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
3717 && e
->symtree
->n
.sym
3718 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
3719 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
)
3720 /* The expression in assoc->target points to a ref to the _data component
3721 of the unlimited polymorphic entity. To get the _len component the last
3722 _data ref needs to be stripped and a ref to the _len component added. */
3723 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
);
3730 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
3734 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
3737 return &gfc_bad_expr
;
3739 if (e
->expr_type
!= EXPR_CONSTANT
)
3742 len
= e
->value
.character
.length
;
3743 for (count
= 0, i
= 1; i
<= len
; i
++)
3744 if (e
->value
.character
.string
[len
- i
] == ' ')
3749 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
3750 return range_check (result
, "LEN_TRIM");
3754 gfc_simplify_lgamma (gfc_expr
*x
)
3759 if (x
->expr_type
!= EXPR_CONSTANT
)
3762 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3763 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
3765 return range_check (result
, "LGAMMA");
3770 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
3772 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3775 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3776 gfc_compare_string (a
, b
) >= 0);
3781 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
3783 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3786 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3787 gfc_compare_string (a
, b
) > 0);
3792 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
3794 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3797 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3798 gfc_compare_string (a
, b
) <= 0);
3803 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
3805 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3808 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3809 gfc_compare_string (a
, b
) < 0);
3814 gfc_simplify_log (gfc_expr
*x
)
3818 if (x
->expr_type
!= EXPR_CONSTANT
)
3821 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3826 if (mpfr_sgn (x
->value
.real
) <= 0)
3828 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3829 "to zero", &x
->where
);
3830 gfc_free_expr (result
);
3831 return &gfc_bad_expr
;
3834 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3838 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
3839 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
3841 gfc_error ("Complex argument of LOG at %L cannot be zero",
3843 gfc_free_expr (result
);
3844 return &gfc_bad_expr
;
3847 gfc_set_model_kind (x
->ts
.kind
);
3848 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
3852 gfc_internal_error ("gfc_simplify_log: bad type");
3855 return range_check (result
, "LOG");
3860 gfc_simplify_log10 (gfc_expr
*x
)
3864 if (x
->expr_type
!= EXPR_CONSTANT
)
3867 if (mpfr_sgn (x
->value
.real
) <= 0)
3869 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3870 "to zero", &x
->where
);
3871 return &gfc_bad_expr
;
3874 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3875 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3877 return range_check (result
, "LOG10");
3882 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
3886 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
3888 return &gfc_bad_expr
;
3890 if (e
->expr_type
!= EXPR_CONSTANT
)
3893 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
3898 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3901 int row
, result_rows
, col
, result_columns
;
3902 int stride_a
, offset_a
, stride_b
, offset_b
;
3904 if (!is_constant_array_expr (matrix_a
)
3905 || !is_constant_array_expr (matrix_b
))
3908 gcc_assert (gfc_compare_types (&matrix_a
->ts
, &matrix_b
->ts
));
3909 result
= gfc_get_array_expr (matrix_a
->ts
.type
,
3913 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
3916 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
3918 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
3921 result
->shape
= gfc_get_shape (result
->rank
);
3922 mpz_init_set_si (result
->shape
[0], result_columns
);
3924 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
3926 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
3928 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
3932 result
->shape
= gfc_get_shape (result
->rank
);
3933 mpz_init_set_si (result
->shape
[0], result_rows
);
3935 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
3937 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
3938 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
3939 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
3940 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
3943 result
->shape
= gfc_get_shape (result
->rank
);
3944 mpz_init_set_si (result
->shape
[0], result_rows
);
3945 mpz_init_set_si (result
->shape
[1], result_columns
);
3950 offset_a
= offset_b
= 0;
3951 for (col
= 0; col
< result_columns
; ++col
)
3955 for (row
= 0; row
< result_rows
; ++row
)
3957 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
3958 matrix_b
, 1, offset_b
, false);
3959 gfc_constructor_append_expr (&result
->value
.constructor
,
3965 offset_b
+= stride_b
;
3973 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
3979 if (i
->expr_type
!= EXPR_CONSTANT
)
3982 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
3984 return &gfc_bad_expr
;
3985 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3987 s
= gfc_extract_int (i
, &arg
);
3990 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
3992 /* MASKR(n) = 2^n - 1 */
3993 mpz_set_ui (result
->value
.integer
, 1);
3994 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
3995 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
3997 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4004 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4011 if (i
->expr_type
!= EXPR_CONSTANT
)
4014 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4016 return &gfc_bad_expr
;
4017 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4019 s
= gfc_extract_int (i
, &arg
);
4022 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4024 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4025 mpz_init_set_ui (z
, 1);
4026 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4027 mpz_set_ui (result
->value
.integer
, 1);
4028 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4029 gfc_integer_kinds
[k
].bit_size
- arg
);
4030 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4033 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4040 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4043 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4045 if (mask
->expr_type
== EXPR_CONSTANT
)
4046 return gfc_get_parentheses (gfc_copy_expr (mask
->value
.logical
4047 ? tsource
: fsource
));
4049 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4050 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4053 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4055 if (tsource
->ts
.type
== BT_DERIVED
)
4056 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4057 else if (tsource
->ts
.type
== BT_CHARACTER
)
4058 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4060 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4061 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4062 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4066 if (mask_ctor
->expr
->value
.logical
)
4067 gfc_constructor_append_expr (&result
->value
.constructor
,
4068 gfc_copy_expr (tsource_ctor
->expr
),
4071 gfc_constructor_append_expr (&result
->value
.constructor
,
4072 gfc_copy_expr (fsource_ctor
->expr
),
4074 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4075 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4076 mask_ctor
= gfc_constructor_next (mask_ctor
);
4079 result
->shape
= gfc_get_shape (1);
4080 gfc_array_size (result
, &result
->shape
[0]);
4087 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4089 mpz_t arg1
, arg2
, mask
;
4092 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4093 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4096 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4098 /* Convert all argument to unsigned. */
4099 mpz_init_set (arg1
, i
->value
.integer
);
4100 mpz_init_set (arg2
, j
->value
.integer
);
4101 mpz_init_set (mask
, mask_expr
->value
.integer
);
4103 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4104 mpz_and (arg1
, arg1
, mask
);
4105 mpz_com (mask
, mask
);
4106 mpz_and (arg2
, arg2
, mask
);
4107 mpz_ior (result
->value
.integer
, arg1
, arg2
);
4117 /* Selects between current value and extremum for simplify_min_max
4118 and simplify_minval_maxval. */
4120 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
)
4122 switch (arg
->ts
.type
)
4125 if (mpz_cmp (arg
->value
.integer
,
4126 extremum
->value
.integer
) * sign
> 0)
4127 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
4131 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4133 mpfr_max (extremum
->value
.real
, extremum
->value
.real
,
4134 arg
->value
.real
, GFC_RND_MODE
);
4136 mpfr_min (extremum
->value
.real
, extremum
->value
.real
,
4137 arg
->value
.real
, GFC_RND_MODE
);
4141 #define LENGTH(x) ((x)->value.character.length)
4142 #define STRING(x) ((x)->value.character.string)
4143 if (LENGTH (extremum
) < LENGTH(arg
))
4145 gfc_char_t
*tmp
= STRING(extremum
);
4147 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
4148 memcpy (STRING(extremum
), tmp
,
4149 LENGTH(extremum
) * sizeof (gfc_char_t
));
4150 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
4151 LENGTH(arg
) - LENGTH(extremum
));
4152 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
4153 LENGTH(extremum
) = LENGTH(arg
);
4157 if (gfc_compare_string (arg
, extremum
) * sign
> 0)
4159 free (STRING(extremum
));
4160 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
4161 memcpy (STRING(extremum
), STRING(arg
),
4162 LENGTH(arg
) * sizeof (gfc_char_t
));
4163 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
4164 LENGTH(extremum
) - LENGTH(arg
));
4165 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
4172 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4177 /* This function is special since MAX() can take any number of
4178 arguments. The simplified expression is a rewritten version of the
4179 argument list containing at most one constant element. Other
4180 constant elements are deleted. Because the argument list has
4181 already been checked, this function always succeeds. sign is 1 for
4182 MAX(), -1 for MIN(). */
4185 simplify_min_max (gfc_expr
*expr
, int sign
)
4187 gfc_actual_arglist
*arg
, *last
, *extremum
;
4188 gfc_intrinsic_sym
* specific
;
4192 specific
= expr
->value
.function
.isym
;
4194 arg
= expr
->value
.function
.actual
;
4196 for (; arg
; last
= arg
, arg
= arg
->next
)
4198 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
4201 if (extremum
== NULL
)
4207 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
4209 /* Delete the extra constant argument. */
4210 last
->next
= arg
->next
;
4213 gfc_free_actual_arglist (arg
);
4217 /* If there is one value left, replace the function call with the
4219 if (expr
->value
.function
.actual
->next
!= NULL
)
4222 /* Convert to the correct type and kind. */
4223 if (expr
->ts
.type
!= BT_UNKNOWN
)
4224 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4225 expr
->ts
.type
, expr
->ts
.kind
);
4227 if (specific
->ts
.type
!= BT_UNKNOWN
)
4228 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4229 specific
->ts
.type
, specific
->ts
.kind
);
4231 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
4236 gfc_simplify_min (gfc_expr
*e
)
4238 return simplify_min_max (e
, -1);
4243 gfc_simplify_max (gfc_expr
*e
)
4245 return simplify_min_max (e
, 1);
4249 /* This is a simplified version of simplify_min_max to provide
4250 simplification of minval and maxval for a vector. */
4253 simplify_minval_maxval (gfc_expr
*expr
, int sign
)
4255 gfc_constructor
*c
, *extremum
;
4256 gfc_intrinsic_sym
* specific
;
4259 specific
= expr
->value
.function
.isym
;
4261 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4262 c
; c
= gfc_constructor_next (c
))
4264 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4267 if (extremum
== NULL
)
4273 min_max_choose (c
->expr
, extremum
->expr
, sign
);
4276 if (extremum
== NULL
)
4279 /* Convert to the correct type and kind. */
4280 if (expr
->ts
.type
!= BT_UNKNOWN
)
4281 return gfc_convert_constant (extremum
->expr
,
4282 expr
->ts
.type
, expr
->ts
.kind
);
4284 if (specific
->ts
.type
!= BT_UNKNOWN
)
4285 return gfc_convert_constant (extremum
->expr
,
4286 specific
->ts
.type
, specific
->ts
.kind
);
4288 return gfc_copy_expr (extremum
->expr
);
4293 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4295 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4298 return simplify_minval_maxval (array
, -1);
4303 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4305 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4308 return simplify_minval_maxval (array
, 1);
4313 gfc_simplify_maxexponent (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
].max_exponent
);
4322 gfc_simplify_minexponent (gfc_expr
*x
)
4324 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4325 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4326 gfc_real_kinds
[i
].min_exponent
);
4331 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
4336 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4339 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4340 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4345 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4347 /* Result is processor-dependent. */
4348 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
4349 gfc_free_expr (result
);
4350 return &gfc_bad_expr
;
4352 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4356 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4358 /* Result is processor-dependent. */
4359 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
4360 gfc_free_expr (result
);
4361 return &gfc_bad_expr
;
4364 gfc_set_model_kind (kind
);
4365 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4370 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4373 return range_check (result
, "MOD");
4378 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
4383 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4386 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4387 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4392 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4394 /* Result is processor-dependent. This processor just opts
4395 to not handle it at all. */
4396 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
4397 gfc_free_expr (result
);
4398 return &gfc_bad_expr
;
4400 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4405 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4407 /* Result is processor-dependent. */
4408 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
4409 gfc_free_expr (result
);
4410 return &gfc_bad_expr
;
4413 gfc_set_model_kind (kind
);
4414 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4416 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
4418 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
4419 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
4423 mpfr_copysign (result
->value
.real
, result
->value
.real
,
4424 p
->value
.real
, GFC_RND_MODE
);
4428 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4431 return range_check (result
, "MODULO");
4435 /* Exists for the sole purpose of consistency with other intrinsics. */
4437 gfc_simplify_mvbits (gfc_expr
*f ATTRIBUTE_UNUSED
,
4438 gfc_expr
*fp ATTRIBUTE_UNUSED
,
4439 gfc_expr
*l ATTRIBUTE_UNUSED
,
4440 gfc_expr
*to ATTRIBUTE_UNUSED
,
4441 gfc_expr
*tp ATTRIBUTE_UNUSED
)
4448 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
4451 mp_exp_t emin
, emax
;
4454 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
4457 result
= gfc_copy_expr (x
);
4459 /* Save current values of emin and emax. */
4460 emin
= mpfr_get_emin ();
4461 emax
= mpfr_get_emax ();
4463 /* Set emin and emax for the current model number. */
4464 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
4465 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
4466 mpfr_get_prec(result
->value
.real
) + 1);
4467 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
4468 mpfr_check_range (result
->value
.real
, 0, GMP_RNDU
);
4470 if (mpfr_sgn (s
->value
.real
) > 0)
4472 mpfr_nextabove (result
->value
.real
);
4473 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
4477 mpfr_nextbelow (result
->value
.real
);
4478 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
4481 mpfr_set_emin (emin
);
4482 mpfr_set_emax (emax
);
4484 /* Only NaN can occur. Do not use range check as it gives an
4485 error for denormal numbers. */
4486 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
4488 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
4489 gfc_free_expr (result
);
4490 return &gfc_bad_expr
;
4498 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
4500 gfc_expr
*itrunc
, *result
;
4503 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
4505 return &gfc_bad_expr
;
4507 if (e
->expr_type
!= EXPR_CONSTANT
)
4510 itrunc
= gfc_copy_expr (e
);
4511 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
4513 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
4514 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
4516 gfc_free_expr (itrunc
);
4518 return range_check (result
, name
);
4523 gfc_simplify_new_line (gfc_expr
*e
)
4527 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
4528 result
->value
.character
.string
[0] = '\n';
4535 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
4537 return simplify_nint ("NINT", e
, k
);
4542 gfc_simplify_idnint (gfc_expr
*e
)
4544 return simplify_nint ("IDNINT", e
, NULL
);
4549 add_squared (gfc_expr
*result
, gfc_expr
*e
)
4553 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4554 gcc_assert (result
->ts
.type
== BT_REAL
4555 && result
->expr_type
== EXPR_CONSTANT
);
4557 gfc_set_model_kind (result
->ts
.kind
);
4559 mpfr_pow_ui (tmp
, e
->value
.real
, 2, GFC_RND_MODE
);
4560 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
4569 do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
4571 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4572 gcc_assert (result
->ts
.type
== BT_REAL
4573 && result
->expr_type
== EXPR_CONSTANT
);
4575 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
4576 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4582 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
4586 if (!is_constant_array_expr (e
)
4587 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
4590 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4591 init_result_expr (result
, 0, NULL
);
4593 if (!dim
|| e
->rank
== 1)
4595 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
4597 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4600 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
4601 add_squared
, &do_sqrt
);
4608 gfc_simplify_not (gfc_expr
*e
)
4612 if (e
->expr_type
!= EXPR_CONSTANT
)
4615 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4616 mpz_com (result
->value
.integer
, e
->value
.integer
);
4618 return range_check (result
, "NOT");
4623 gfc_simplify_null (gfc_expr
*mold
)
4629 result
= gfc_copy_expr (mold
);
4630 result
->expr_type
= EXPR_NULL
;
4633 result
= gfc_get_null_expr (NULL
);
4640 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
4644 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4646 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4647 return &gfc_bad_expr
;
4650 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
4653 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
4656 /* FIXME: gfc_current_locus is wrong. */
4657 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
4658 &gfc_current_locus
);
4660 if (failed
&& failed
->value
.logical
!= 0)
4661 mpz_set_si (result
->value
.integer
, 0);
4663 mpz_set_si (result
->value
.integer
, 1);
4670 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
4675 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4678 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4683 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
4684 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4685 return range_check (result
, "OR");
4688 return gfc_get_logical_expr (kind
, &x
->where
,
4689 x
->value
.logical
|| y
->value
.logical
);
4697 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4700 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
4702 if (!is_constant_array_expr (array
)
4703 || !is_constant_array_expr (vector
)
4704 || (!gfc_is_constant_expr (mask
)
4705 && !is_constant_array_expr (mask
)))
4708 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
4709 if (array
->ts
.type
== BT_DERIVED
)
4710 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
4712 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
4713 vector_ctor
= vector
4714 ? gfc_constructor_first (vector
->value
.constructor
)
4717 if (mask
->expr_type
== EXPR_CONSTANT
4718 && mask
->value
.logical
)
4720 /* Copy all elements of ARRAY to RESULT. */
4723 gfc_constructor_append_expr (&result
->value
.constructor
,
4724 gfc_copy_expr (array_ctor
->expr
),
4727 array_ctor
= gfc_constructor_next (array_ctor
);
4728 vector_ctor
= gfc_constructor_next (vector_ctor
);
4731 else if (mask
->expr_type
== EXPR_ARRAY
)
4733 /* Copy only those elements of ARRAY to RESULT whose
4734 MASK equals .TRUE.. */
4735 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4738 if (mask_ctor
->expr
->value
.logical
)
4740 gfc_constructor_append_expr (&result
->value
.constructor
,
4741 gfc_copy_expr (array_ctor
->expr
),
4743 vector_ctor
= gfc_constructor_next (vector_ctor
);
4746 array_ctor
= gfc_constructor_next (array_ctor
);
4747 mask_ctor
= gfc_constructor_next (mask_ctor
);
4751 /* Append any left-over elements from VECTOR to RESULT. */
4754 gfc_constructor_append_expr (&result
->value
.constructor
,
4755 gfc_copy_expr (vector_ctor
->expr
),
4757 vector_ctor
= gfc_constructor_next (vector_ctor
);
4760 result
->shape
= gfc_get_shape (1);
4761 gfc_array_size (result
, &result
->shape
[0]);
4763 if (array
->ts
.type
== BT_CHARACTER
)
4764 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
4771 do_xor (gfc_expr
*result
, gfc_expr
*e
)
4773 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
4774 gcc_assert (result
->ts
.type
== BT_LOGICAL
4775 && result
->expr_type
== EXPR_CONSTANT
);
4777 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
4784 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
4786 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
4791 gfc_simplify_popcnt (gfc_expr
*e
)
4796 if (e
->expr_type
!= EXPR_CONSTANT
)
4799 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4801 /* Convert argument to unsigned, then count the '1' bits. */
4802 mpz_init_set (x
, e
->value
.integer
);
4803 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
4804 res
= mpz_popcount (x
);
4807 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
4812 gfc_simplify_poppar (gfc_expr
*e
)
4818 if (e
->expr_type
!= EXPR_CONSTANT
)
4821 popcnt
= gfc_simplify_popcnt (e
);
4822 gcc_assert (popcnt
);
4824 s
= gfc_extract_int (popcnt
, &i
);
4827 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
4832 gfc_simplify_precision (gfc_expr
*e
)
4834 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4835 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
4836 gfc_real_kinds
[i
].precision
);
4841 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
4843 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
4848 gfc_simplify_radix (gfc_expr
*e
)
4851 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4856 i
= gfc_integer_kinds
[i
].radix
;
4860 i
= gfc_real_kinds
[i
].radix
;
4867 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4872 gfc_simplify_range (gfc_expr
*e
)
4875 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4880 i
= gfc_integer_kinds
[i
].range
;
4885 i
= gfc_real_kinds
[i
].range
;
4892 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4897 gfc_simplify_rank (gfc_expr
*e
)
4903 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
4908 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
4910 gfc_expr
*result
= NULL
;
4913 if (e
->ts
.type
== BT_COMPLEX
)
4914 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
4916 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
4919 return &gfc_bad_expr
;
4921 if (e
->expr_type
!= EXPR_CONSTANT
)
4924 if (convert_boz (e
, kind
) == &gfc_bad_expr
)
4925 return &gfc_bad_expr
;
4927 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
4928 if (result
== &gfc_bad_expr
)
4929 return &gfc_bad_expr
;
4931 return range_check (result
, "REAL");
4936 gfc_simplify_realpart (gfc_expr
*e
)
4940 if (e
->expr_type
!= EXPR_CONSTANT
)
4943 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
4944 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
4946 return range_check (result
, "REALPART");
4950 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
4953 int i
, j
, len
, ncop
, nlen
;
4955 bool have_length
= false;
4957 /* If NCOPIES isn't a constant, there's nothing we can do. */
4958 if (n
->expr_type
!= EXPR_CONSTANT
)
4961 /* If NCOPIES is negative, it's an error. */
4962 if (mpz_sgn (n
->value
.integer
) < 0)
4964 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4966 return &gfc_bad_expr
;
4969 /* If we don't know the character length, we can do no more. */
4970 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
4971 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4973 len
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
4976 else if (e
->expr_type
== EXPR_CONSTANT
4977 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
4979 len
= e
->value
.character
.length
;
4984 /* If the source length is 0, any value of NCOPIES is valid
4985 and everything behaves as if NCOPIES == 0. */
4988 mpz_set_ui (ncopies
, 0);
4990 mpz_set (ncopies
, n
->value
.integer
);
4992 /* Check that NCOPIES isn't too large. */
4998 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
5000 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5004 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
5005 e
->ts
.u
.cl
->length
->value
.integer
);
5009 mpz_init_set_si (mlen
, len
);
5010 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
5014 /* The check itself. */
5015 if (mpz_cmp (ncopies
, max
) > 0)
5018 mpz_clear (ncopies
);
5019 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
5021 return &gfc_bad_expr
;
5026 mpz_clear (ncopies
);
5028 /* For further simplification, we need the character string to be
5030 if (e
->expr_type
!= EXPR_CONSTANT
)
5034 (e
->ts
.u
.cl
->length
&&
5035 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
)) != 0)
5037 const char *res
= gfc_extract_int (n
, &ncop
);
5038 gcc_assert (res
== NULL
);
5044 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
5046 len
= e
->value
.character
.length
;
5049 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
5050 for (i
= 0; i
< ncop
; i
++)
5051 for (j
= 0; j
< len
; j
++)
5052 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
5054 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
5059 /* This one is a bear, but mainly has to do with shuffling elements. */
5062 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
5063 gfc_expr
*pad
, gfc_expr
*order_exp
)
5065 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
5066 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
5070 gfc_expr
*e
, *result
;
5072 /* Check that argument expression types are OK. */
5073 if (!is_constant_array_expr (source
)
5074 || !is_constant_array_expr (shape_exp
)
5075 || !is_constant_array_expr (pad
)
5076 || !is_constant_array_expr (order_exp
))
5079 /* Proceed with simplification, unpacking the array. */
5086 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
5090 gfc_extract_int (e
, &shape
[rank
]);
5092 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
5093 gcc_assert (shape
[rank
] >= 0);
5098 gcc_assert (rank
> 0);
5100 /* Now unpack the order array if present. */
5101 if (order_exp
== NULL
)
5103 for (i
= 0; i
< rank
; i
++)
5108 for (i
= 0; i
< rank
; i
++)
5111 for (i
= 0; i
< rank
; i
++)
5113 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
5116 gfc_extract_int (e
, &order
[i
]);
5118 gcc_assert (order
[i
] >= 1 && order
[i
] <= rank
);
5120 gcc_assert (x
[order
[i
]] == 0);
5125 /* Count the elements in the source and padding arrays. */
5130 gfc_array_size (pad
, &size
);
5131 npad
= mpz_get_ui (size
);
5135 gfc_array_size (source
, &size
);
5136 nsource
= mpz_get_ui (size
);
5139 /* If it weren't for that pesky permutation we could just loop
5140 through the source and round out any shortage with pad elements.
5141 But no, someone just had to have the compiler do something the
5142 user should be doing. */
5144 for (i
= 0; i
< rank
; i
++)
5147 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
5149 if (source
->ts
.type
== BT_DERIVED
)
5150 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
5151 result
->rank
= rank
;
5152 result
->shape
= gfc_get_shape (rank
);
5153 for (i
= 0; i
< rank
; i
++)
5154 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
5156 while (nsource
> 0 || npad
> 0)
5158 /* Figure out which element to extract. */
5159 mpz_set_ui (index
, 0);
5161 for (i
= rank
- 1; i
>= 0; i
--)
5163 mpz_add_ui (index
, index
, x
[order
[i
]]);
5165 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
5168 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
5169 gfc_internal_error ("Reshaped array too large at %C");
5171 j
= mpz_get_ui (index
);
5174 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
5177 gcc_assert (npad
> 0);
5181 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
5185 gfc_constructor_append_expr (&result
->value
.constructor
,
5186 gfc_copy_expr (e
), &e
->where
);
5188 /* Calculate the next element. */
5192 if (++x
[i
] < shape
[i
])
5208 gfc_simplify_rrspacing (gfc_expr
*x
)
5214 if (x
->expr_type
!= EXPR_CONSTANT
)
5217 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5219 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5221 /* RRSPACING(+/- 0.0) = 0.0 */
5222 if (mpfr_zero_p (x
->value
.real
))
5224 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5228 /* RRSPACING(inf) = NaN */
5229 if (mpfr_inf_p (x
->value
.real
))
5231 mpfr_set_nan (result
->value
.real
);
5235 /* RRSPACING(NaN) = same NaN */
5236 if (mpfr_nan_p (x
->value
.real
))
5238 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5242 /* | x * 2**(-e) | * 2**p. */
5243 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5244 e
= - (long int) mpfr_get_exp (x
->value
.real
);
5245 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
5247 p
= (long int) gfc_real_kinds
[i
].digits
;
5248 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
5250 return range_check (result
, "RRSPACING");
5255 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
5257 int k
, neg_flag
, power
, exp_range
;
5258 mpfr_t scale
, radix
;
5261 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5264 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5266 if (mpfr_zero_p (x
->value
.real
))
5268 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5272 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5274 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
5276 /* This check filters out values of i that would overflow an int. */
5277 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
5278 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
5280 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
5281 gfc_free_expr (result
);
5282 return &gfc_bad_expr
;
5285 /* Compute scale = radix ** power. */
5286 power
= mpz_get_si (i
->value
.integer
);
5296 gfc_set_model_kind (x
->ts
.kind
);
5299 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
5300 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
5303 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5305 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5307 mpfr_clears (scale
, radix
, NULL
);
5309 return range_check (result
, "SCALE");
5313 /* Variants of strspn and strcspn that operate on wide characters. */
5316 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5319 const gfc_char_t
*c
;
5323 for (c
= s2
; *c
; c
++)
5337 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5340 const gfc_char_t
*c
;
5344 for (c
= s2
; *c
; c
++)
5359 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
5364 size_t indx
, len
, lenc
;
5365 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
5368 return &gfc_bad_expr
;
5370 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
5371 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
5374 if (b
!= NULL
&& b
->value
.logical
!= 0)
5379 len
= e
->value
.character
.length
;
5380 lenc
= c
->value
.character
.length
;
5382 if (len
== 0 || lenc
== 0)
5390 indx
= wide_strcspn (e
->value
.character
.string
,
5391 c
->value
.character
.string
) + 1;
5398 for (indx
= len
; indx
> 0; indx
--)
5400 for (i
= 0; i
< lenc
; i
++)
5402 if (c
->value
.character
.string
[i
]
5403 == e
->value
.character
.string
[indx
- 1])
5412 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
5413 return range_check (result
, "SCAN");
5418 gfc_simplify_selected_char_kind (gfc_expr
*e
)
5422 if (e
->expr_type
!= EXPR_CONSTANT
)
5425 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
5426 || gfc_compare_with_Cstring (e
, "default", false) == 0)
5428 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
5433 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5438 gfc_simplify_selected_int_kind (gfc_expr
*e
)
5442 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
5447 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
5448 if (gfc_integer_kinds
[i
].range
>= range
5449 && gfc_integer_kinds
[i
].kind
< kind
)
5450 kind
= gfc_integer_kinds
[i
].kind
;
5452 if (kind
== INT_MAX
)
5455 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5460 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
5462 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
5464 locus
*loc
= &gfc_current_locus
;
5470 if (p
->expr_type
!= EXPR_CONSTANT
5471 || gfc_extract_int (p
, &precision
) != NULL
)
5480 if (q
->expr_type
!= EXPR_CONSTANT
5481 || gfc_extract_int (q
, &range
) != NULL
)
5492 if (rdx
->expr_type
!= EXPR_CONSTANT
5493 || gfc_extract_int (rdx
, &radix
) != NULL
)
5501 found_precision
= 0;
5505 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5507 if (gfc_real_kinds
[i
].precision
>= precision
)
5508 found_precision
= 1;
5510 if (gfc_real_kinds
[i
].range
>= range
)
5513 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5516 if (gfc_real_kinds
[i
].precision
>= precision
5517 && gfc_real_kinds
[i
].range
>= range
5518 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5519 && gfc_real_kinds
[i
].kind
< kind
)
5520 kind
= gfc_real_kinds
[i
].kind
;
5523 if (kind
== INT_MAX
)
5525 if (found_radix
&& found_range
&& !found_precision
)
5527 else if (found_radix
&& found_precision
&& !found_range
)
5529 else if (found_radix
&& !found_precision
&& !found_range
)
5531 else if (found_radix
)
5537 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
5542 gfc_simplify_ieee_selected_real_kind (gfc_expr
*expr
)
5544 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
5545 gfc_expr
*p
= arg
->expr
, *r
= arg
->next
->expr
,
5546 *rad
= arg
->next
->next
->expr
;
5547 int precision
, range
, radix
, res
;
5548 int found_precision
, found_range
, found_radix
, i
;
5552 if (p
->expr_type
!= EXPR_CONSTANT
5553 || gfc_extract_int (p
, &precision
) != NULL
)
5561 if (r
->expr_type
!= EXPR_CONSTANT
5562 || gfc_extract_int (r
, &range
) != NULL
)
5570 if (rad
->expr_type
!= EXPR_CONSTANT
5571 || gfc_extract_int (rad
, &radix
) != NULL
)
5578 found_precision
= 0;
5582 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5584 /* We only support the target's float and double types. */
5585 if (!gfc_real_kinds
[i
].c_float
&& !gfc_real_kinds
[i
].c_double
)
5588 if (gfc_real_kinds
[i
].precision
>= precision
)
5589 found_precision
= 1;
5591 if (gfc_real_kinds
[i
].range
>= range
)
5594 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5597 if (gfc_real_kinds
[i
].precision
>= precision
5598 && gfc_real_kinds
[i
].range
>= range
5599 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5600 && gfc_real_kinds
[i
].kind
< res
)
5601 res
= gfc_real_kinds
[i
].kind
;
5606 if (found_radix
&& found_range
&& !found_precision
)
5608 else if (found_radix
&& found_precision
&& !found_range
)
5610 else if (found_radix
&& !found_precision
&& !found_range
)
5612 else if (found_radix
)
5618 return gfc_get_int_expr (gfc_default_integer_kind
, &expr
->where
, res
);
5623 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5626 mpfr_t exp
, absv
, log2
, pow2
, frac
;
5629 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5632 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5634 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
5635 SET_EXPONENT (NaN) = same NaN */
5636 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
5638 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5642 /* SET_EXPONENT (inf) = NaN */
5643 if (mpfr_inf_p (x
->value
.real
))
5645 mpfr_set_nan (result
->value
.real
);
5649 gfc_set_model_kind (x
->ts
.kind
);
5656 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
5657 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
5659 mpfr_trunc (log2
, log2
);
5660 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
5662 /* Old exponent value, and fraction. */
5663 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
5665 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
5668 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
5669 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
5671 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
5673 return range_check (result
, "SET_EXPONENT");
5678 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
5680 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5681 gfc_expr
*result
, *e
, *f
;
5685 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
5687 if (source
->rank
== -1)
5690 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
5692 if (source
->rank
== 0)
5695 if (source
->expr_type
== EXPR_VARIABLE
)
5697 ar
= gfc_find_array_ref (source
);
5698 t
= gfc_array_ref_shape (ar
, shape
);
5700 else if (source
->shape
)
5703 for (n
= 0; n
< source
->rank
; n
++)
5705 mpz_init (shape
[n
]);
5706 mpz_set (shape
[n
], source
->shape
[n
]);
5712 for (n
= 0; n
< source
->rank
; n
++)
5714 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
5717 mpz_set (e
->value
.integer
, shape
[n
]);
5720 mpz_set_ui (e
->value
.integer
, n
+ 1);
5722 f
= simplify_size (source
, e
, k
);
5726 gfc_free_expr (result
);
5733 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
5735 gfc_free_expr (result
);
5737 gfc_clear_shape (shape
, source
->rank
);
5738 return &gfc_bad_expr
;
5741 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
5745 gfc_clear_shape (shape
, source
->rank
);
5752 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
5755 gfc_expr
*return_value
;
5758 /* For unary operations, the size of the result is given by the size
5759 of the operand. For binary ones, it's the size of the first operand
5760 unless it is scalar, then it is the size of the second. */
5761 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
5763 gfc_expr
* replacement
;
5764 gfc_expr
* simplified
;
5766 switch (array
->value
.op
.op
)
5768 /* Unary operations. */
5770 case INTRINSIC_UPLUS
:
5771 case INTRINSIC_UMINUS
:
5772 case INTRINSIC_PARENTHESES
:
5773 replacement
= array
->value
.op
.op1
;
5776 /* Binary operations. If any one of the operands is scalar, take
5777 the other one's size. If both of them are arrays, it does not
5778 matter -- try to find one with known shape, if possible. */
5780 if (array
->value
.op
.op1
->rank
== 0)
5781 replacement
= array
->value
.op
.op2
;
5782 else if (array
->value
.op
.op2
->rank
== 0)
5783 replacement
= array
->value
.op
.op1
;
5786 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
5790 replacement
= array
->value
.op
.op2
;
5795 /* Try to reduce it directly if possible. */
5796 simplified
= simplify_size (replacement
, dim
, k
);
5798 /* Otherwise, we build a new SIZE call. This is hopefully at least
5799 simpler than the original one. */
5802 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
5803 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
5804 GFC_ISYM_SIZE
, "size",
5806 gfc_copy_expr (replacement
),
5807 gfc_copy_expr (dim
),
5815 if (!gfc_array_size (array
, &size
))
5820 if (dim
->expr_type
!= EXPR_CONSTANT
)
5823 d
= mpz_get_ui (dim
->value
.integer
) - 1;
5824 if (!gfc_array_dimen_size (array
, d
, &size
))
5828 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
5829 mpz_set (return_value
->value
.integer
, size
);
5832 return return_value
;
5837 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5840 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
5843 return &gfc_bad_expr
;
5845 result
= simplify_size (array
, dim
, k
);
5846 if (result
== NULL
|| result
== &gfc_bad_expr
)
5849 return range_check (result
, "SIZE");
5853 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
5854 multiplied by the array size. */
5857 gfc_simplify_sizeof (gfc_expr
*x
)
5859 gfc_expr
*result
= NULL
;
5862 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
5865 if (x
->ts
.type
== BT_CHARACTER
5866 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
5867 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
5870 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
5871 && !gfc_array_size (x
, &array_size
))
5874 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
5876 mpz_set_si (result
->value
.integer
, gfc_target_expr_size (x
));
5882 /* STORAGE_SIZE returns the size in bits of a single array element. */
5885 gfc_simplify_storage_size (gfc_expr
*x
,
5888 gfc_expr
*result
= NULL
;
5891 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
5894 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
5895 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
5896 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
5899 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
5901 return &gfc_bad_expr
;
5903 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
5905 mpz_set_si (result
->value
.integer
, gfc_element_size (x
));
5906 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
5908 return range_check (result
, "STORAGE_SIZE");
5913 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
5917 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
5920 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5925 mpz_abs (result
->value
.integer
, x
->value
.integer
);
5926 if (mpz_sgn (y
->value
.integer
) < 0)
5927 mpz_neg (result
->value
.integer
, result
->value
.integer
);
5932 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
5935 mpfr_setsign (result
->value
.real
, x
->value
.real
,
5936 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
5940 gfc_internal_error ("Bad type in gfc_simplify_sign");
5948 gfc_simplify_sin (gfc_expr
*x
)
5952 if (x
->expr_type
!= EXPR_CONSTANT
)
5955 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5960 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5964 gfc_set_model (x
->value
.real
);
5965 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5969 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5972 return range_check (result
, "SIN");
5977 gfc_simplify_sinh (gfc_expr
*x
)
5981 if (x
->expr_type
!= EXPR_CONSTANT
)
5984 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5989 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5993 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6000 return range_check (result
, "SINH");
6004 /* The argument is always a double precision real that is converted to
6005 single precision. TODO: Rounding! */
6008 gfc_simplify_sngl (gfc_expr
*a
)
6012 if (a
->expr_type
!= EXPR_CONSTANT
)
6015 result
= gfc_real2real (a
, gfc_default_real_kind
);
6016 return range_check (result
, "SNGL");
6021 gfc_simplify_spacing (gfc_expr
*x
)
6027 if (x
->expr_type
!= EXPR_CONSTANT
)
6030 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
6031 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
6033 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
6034 if (mpfr_zero_p (x
->value
.real
))
6036 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6040 /* SPACING(inf) = NaN */
6041 if (mpfr_inf_p (x
->value
.real
))
6043 mpfr_set_nan (result
->value
.real
);
6047 /* SPACING(NaN) = same NaN */
6048 if (mpfr_nan_p (x
->value
.real
))
6050 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6054 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
6055 are the radix, exponent of x, and precision. This excludes the
6056 possibility of subnormal numbers. Fortran 2003 states the result is
6057 b**max(e - p, emin - 1). */
6059 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
6060 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
6061 en
= en
> ep
? en
: ep
;
6063 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
6064 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
6066 return range_check (result
, "SPACING");
6071 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
6073 gfc_expr
*result
= 0L;
6074 int i
, j
, dim
, ncopies
;
6077 if ((!gfc_is_constant_expr (source
)
6078 && !is_constant_array_expr (source
))
6079 || !gfc_is_constant_expr (dim_expr
)
6080 || !gfc_is_constant_expr (ncopies_expr
))
6083 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
6084 gfc_extract_int (dim_expr
, &dim
);
6085 dim
-= 1; /* zero-base DIM */
6087 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
6088 gfc_extract_int (ncopies_expr
, &ncopies
);
6089 ncopies
= MAX (ncopies
, 0);
6091 /* Do not allow the array size to exceed the limit for an array
6093 if (source
->expr_type
== EXPR_ARRAY
)
6095 if (!gfc_array_size (source
, &size
))
6096 gfc_internal_error ("Failure getting length of a constant array.");
6099 mpz_init_set_ui (size
, 1);
6101 if (mpz_get_si (size
)*ncopies
> flag_max_array_constructor
)
6104 if (source
->expr_type
== EXPR_CONSTANT
)
6106 gcc_assert (dim
== 0);
6108 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6110 if (source
->ts
.type
== BT_DERIVED
)
6111 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6113 result
->shape
= gfc_get_shape (result
->rank
);
6114 mpz_init_set_si (result
->shape
[0], ncopies
);
6116 for (i
= 0; i
< ncopies
; ++i
)
6117 gfc_constructor_append_expr (&result
->value
.constructor
,
6118 gfc_copy_expr (source
), NULL
);
6120 else if (source
->expr_type
== EXPR_ARRAY
)
6122 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
6123 gfc_constructor
*source_ctor
;
6125 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
6126 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
6128 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6130 if (source
->ts
.type
== BT_DERIVED
)
6131 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6132 result
->rank
= source
->rank
+ 1;
6133 result
->shape
= gfc_get_shape (result
->rank
);
6135 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
6138 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
6140 mpz_init_set_si (result
->shape
[i
], ncopies
);
6142 extent
[i
] = mpz_get_si (result
->shape
[i
]);
6143 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
6147 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
6148 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
6150 for (i
= 0; i
< ncopies
; ++i
)
6151 gfc_constructor_insert_expr (&result
->value
.constructor
,
6152 gfc_copy_expr (source_ctor
->expr
),
6153 NULL
, offset
+ i
* rstride
[dim
]);
6155 offset
+= (dim
== 0 ? ncopies
: 1);
6159 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
6160 Replace NULL with gcc_unreachable() after implementing
6161 gfc_simplify_cshift(). */
6164 if (source
->ts
.type
== BT_CHARACTER
)
6165 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
6172 gfc_simplify_sqrt (gfc_expr
*e
)
6174 gfc_expr
*result
= NULL
;
6176 if (e
->expr_type
!= EXPR_CONSTANT
)
6182 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
6184 gfc_error ("Argument of SQRT at %L has a negative value",
6186 return &gfc_bad_expr
;
6188 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6189 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6193 gfc_set_model (e
->value
.real
);
6195 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6196 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
6200 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
6203 return range_check (result
, "SQRT");
6208 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6210 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
6215 gfc_simplify_tan (gfc_expr
*x
)
6219 if (x
->expr_type
!= EXPR_CONSTANT
)
6222 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6227 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6231 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6238 return range_check (result
, "TAN");
6243 gfc_simplify_tanh (gfc_expr
*x
)
6247 if (x
->expr_type
!= EXPR_CONSTANT
)
6250 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6255 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6259 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6266 return range_check (result
, "TANH");
6271 gfc_simplify_tiny (gfc_expr
*e
)
6276 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
6278 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6279 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6286 gfc_simplify_trailz (gfc_expr
*e
)
6288 unsigned long tz
, bs
;
6291 if (e
->expr_type
!= EXPR_CONSTANT
)
6294 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6295 bs
= gfc_integer_kinds
[i
].bit_size
;
6296 tz
= mpz_scan1 (e
->value
.integer
, 0);
6298 return gfc_get_int_expr (gfc_default_integer_kind
,
6299 &e
->where
, MIN (tz
, bs
));
6304 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6307 gfc_expr
*mold_element
;
6312 unsigned char *buffer
;
6313 size_t result_length
;
6316 if (!gfc_is_constant_expr (source
)
6317 || (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
6318 || !gfc_is_constant_expr (size
))
6321 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6322 &result_size
, &result_length
))
6325 /* Calculate the size of the source. */
6326 if (source
->expr_type
== EXPR_ARRAY
6327 && !gfc_array_size (source
, &tmp
))
6328 gfc_internal_error ("Failure getting length of a constant array.");
6330 /* Create an empty new expression with the appropriate characteristics. */
6331 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
6333 result
->ts
= mold
->ts
;
6335 mold_element
= mold
->expr_type
== EXPR_ARRAY
6336 ? gfc_constructor_first (mold
->value
.constructor
)->expr
6339 /* Set result character length, if needed. Note that this needs to be
6340 set even for array expressions, in order to pass this information into
6341 gfc_target_interpret_expr. */
6342 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
6343 result
->value
.character
.length
= mold_element
->value
.character
.length
;
6345 /* Set the number of elements in the result, and determine its size. */
6347 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
6349 result
->expr_type
= EXPR_ARRAY
;
6351 result
->shape
= gfc_get_shape (1);
6352 mpz_init_set_ui (result
->shape
[0], result_length
);
6357 /* Allocate the buffer to store the binary version of the source. */
6358 buffer_size
= MAX (source_size
, result_size
);
6359 buffer
= (unsigned char*)alloca (buffer_size
);
6360 memset (buffer
, 0, buffer_size
);
6362 /* Now write source to the buffer. */
6363 gfc_target_encode_expr (source
, buffer
, buffer_size
);
6365 /* And read the buffer back into the new expression. */
6366 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
6373 gfc_simplify_transpose (gfc_expr
*matrix
)
6375 int row
, matrix_rows
, col
, matrix_cols
;
6378 if (!is_constant_array_expr (matrix
))
6381 gcc_assert (matrix
->rank
== 2);
6383 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
6386 result
->shape
= gfc_get_shape (result
->rank
);
6387 mpz_set (result
->shape
[0], matrix
->shape
[1]);
6388 mpz_set (result
->shape
[1], matrix
->shape
[0]);
6390 if (matrix
->ts
.type
== BT_CHARACTER
)
6391 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
6392 else if (matrix
->ts
.type
== BT_DERIVED
)
6393 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
6395 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
6396 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
6397 for (row
= 0; row
< matrix_rows
; ++row
)
6398 for (col
= 0; col
< matrix_cols
; ++col
)
6400 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
6401 col
* matrix_rows
+ row
);
6402 gfc_constructor_insert_expr (&result
->value
.constructor
,
6403 gfc_copy_expr (e
), &matrix
->where
,
6404 row
* matrix_cols
+ col
);
6412 gfc_simplify_trim (gfc_expr
*e
)
6415 int count
, i
, len
, lentrim
;
6417 if (e
->expr_type
!= EXPR_CONSTANT
)
6420 len
= e
->value
.character
.length
;
6421 for (count
= 0, i
= 1; i
<= len
; ++i
)
6423 if (e
->value
.character
.string
[len
- i
] == ' ')
6429 lentrim
= len
- count
;
6431 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
6432 for (i
= 0; i
< lentrim
; i
++)
6433 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
6440 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
6445 gfc_constructor
*sub_cons
;
6449 if (!is_constant_array_expr (sub
))
6452 /* Follow any component references. */
6453 as
= coarray
->symtree
->n
.sym
->as
;
6454 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
6455 if (ref
->type
== REF_COMPONENT
)
6458 if (as
->type
== AS_DEFERRED
)
6461 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6462 the cosubscript addresses the first image. */
6464 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
6467 for (d
= 1; d
<= as
->corank
; d
++)
6472 gcc_assert (sub_cons
!= NULL
);
6474 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
6476 if (ca_bound
== NULL
)
6479 if (ca_bound
== &gfc_bad_expr
)
6482 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
6486 gfc_free_expr (ca_bound
);
6487 sub_cons
= gfc_constructor_next (sub_cons
);
6491 first_image
= false;
6495 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6496 "SUB has %ld and COARRAY lower bound is %ld)",
6498 mpz_get_si (sub_cons
->expr
->value
.integer
),
6499 mpz_get_si (ca_bound
->value
.integer
));
6500 gfc_free_expr (ca_bound
);
6501 return &gfc_bad_expr
;
6504 gfc_free_expr (ca_bound
);
6506 /* Check whether upperbound is valid for the multi-images case. */
6509 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
6511 if (ca_bound
== &gfc_bad_expr
)
6514 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
6515 && mpz_cmp (ca_bound
->value
.integer
,
6516 sub_cons
->expr
->value
.integer
) < 0)
6518 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6519 "SUB has %ld and COARRAY upper bound is %ld)",
6521 mpz_get_si (sub_cons
->expr
->value
.integer
),
6522 mpz_get_si (ca_bound
->value
.integer
));
6523 gfc_free_expr (ca_bound
);
6524 return &gfc_bad_expr
;
6528 gfc_free_expr (ca_bound
);
6531 sub_cons
= gfc_constructor_next (sub_cons
);
6534 gcc_assert (sub_cons
== NULL
);
6536 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
6539 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6540 &gfc_current_locus
);
6542 mpz_set_si (result
->value
.integer
, 1);
6544 mpz_set_si (result
->value
.integer
, 0);
6551 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
6552 gfc_expr
*distance ATTRIBUTE_UNUSED
)
6554 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6557 /* If no coarray argument has been passed or when the first argument
6558 is actually a distance argment. */
6559 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
6562 /* FIXME: gfc_current_locus is wrong. */
6563 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6564 &gfc_current_locus
);
6565 mpz_set_si (result
->value
.integer
, 1);
6569 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
6570 return simplify_cobound (coarray
, dim
, NULL
, 0);
6575 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6577 return simplify_bound (array
, dim
, kind
, 1);
6581 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6583 return simplify_cobound (array
, dim
, kind
, 1);
6588 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6590 gfc_expr
*result
, *e
;
6591 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
6593 if (!is_constant_array_expr (vector
)
6594 || !is_constant_array_expr (mask
)
6595 || (!gfc_is_constant_expr (field
)
6596 && !is_constant_array_expr (field
)))
6599 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
6601 if (vector
->ts
.type
== BT_DERIVED
)
6602 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
6603 result
->rank
= mask
->rank
;
6604 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
6606 if (vector
->ts
.type
== BT_CHARACTER
)
6607 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
6609 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
6610 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6612 = field
->expr_type
== EXPR_ARRAY
6613 ? gfc_constructor_first (field
->value
.constructor
)
6618 if (mask_ctor
->expr
->value
.logical
)
6620 gcc_assert (vector_ctor
);
6621 e
= gfc_copy_expr (vector_ctor
->expr
);
6622 vector_ctor
= gfc_constructor_next (vector_ctor
);
6624 else if (field
->expr_type
== EXPR_ARRAY
)
6625 e
= gfc_copy_expr (field_ctor
->expr
);
6627 e
= gfc_copy_expr (field
);
6629 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
6631 mask_ctor
= gfc_constructor_next (mask_ctor
);
6632 field_ctor
= gfc_constructor_next (field_ctor
);
6640 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
6644 size_t index
, len
, lenset
;
6646 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
6649 return &gfc_bad_expr
;
6651 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
6652 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
6655 if (b
!= NULL
&& b
->value
.logical
!= 0)
6660 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
6662 len
= s
->value
.character
.length
;
6663 lenset
= set
->value
.character
.length
;
6667 mpz_set_ui (result
->value
.integer
, 0);
6675 mpz_set_ui (result
->value
.integer
, 1);
6679 index
= wide_strspn (s
->value
.character
.string
,
6680 set
->value
.character
.string
) + 1;
6689 mpz_set_ui (result
->value
.integer
, len
);
6692 for (index
= len
; index
> 0; index
--)
6694 for (i
= 0; i
< lenset
; i
++)
6696 if (s
->value
.character
.string
[index
- 1]
6697 == set
->value
.character
.string
[i
])
6705 mpz_set_ui (result
->value
.integer
, index
);
6711 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
6716 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6719 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6724 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6725 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6726 return range_check (result
, "XOR");
6729 return gfc_get_logical_expr (kind
, &x
->where
,
6730 (x
->value
.logical
&& !y
->value
.logical
)
6731 || (!x
->value
.logical
&& y
->value
.logical
));
6739 /****************** Constant simplification *****************/
6741 /* Master function to convert one constant to another. While this is
6742 used as a simplification function, it requires the destination type
6743 and kind information which is supplied by a special case in
6747 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
6749 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
6764 f
= gfc_int2complex
;
6784 f
= gfc_real2complex
;
6795 f
= gfc_complex2int
;
6798 f
= gfc_complex2real
;
6801 f
= gfc_complex2complex
;
6827 f
= gfc_hollerith2int
;
6831 f
= gfc_hollerith2real
;
6835 f
= gfc_hollerith2complex
;
6839 f
= gfc_hollerith2character
;
6843 f
= gfc_hollerith2logical
;
6853 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6858 switch (e
->expr_type
)
6861 result
= f (e
, kind
);
6863 return &gfc_bad_expr
;
6867 if (!gfc_is_constant_expr (e
))
6870 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6871 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6872 result
->rank
= e
->rank
;
6874 for (c
= gfc_constructor_first (e
->value
.constructor
);
6875 c
; c
= gfc_constructor_next (c
))
6878 if (c
->iterator
== NULL
)
6879 tmp
= f (c
->expr
, kind
);
6882 g
= gfc_convert_constant (c
->expr
, type
, kind
);
6883 if (g
== &gfc_bad_expr
)
6885 gfc_free_expr (result
);
6893 gfc_free_expr (result
);
6897 gfc_constructor_append_expr (&result
->value
.constructor
,
6911 /* Function for converting character constants. */
6913 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
6918 if (!gfc_is_constant_expr (e
))
6921 if (e
->expr_type
== EXPR_CONSTANT
)
6923 /* Simple case of a scalar. */
6924 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
6926 return &gfc_bad_expr
;
6928 result
->value
.character
.length
= e
->value
.character
.length
;
6929 result
->value
.character
.string
6930 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
6931 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
6932 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
6934 /* Check we only have values representable in the destination kind. */
6935 for (i
= 0; i
< result
->value
.character
.length
; i
++)
6936 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
6939 gfc_error ("Character %qs in string at %L cannot be converted "
6940 "into character kind %d",
6941 gfc_print_wide_char (result
->value
.character
.string
[i
]),
6943 return &gfc_bad_expr
;
6948 else if (e
->expr_type
== EXPR_ARRAY
)
6950 /* For an array constructor, we convert each constructor element. */
6953 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6954 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6955 result
->rank
= e
->rank
;
6956 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
6958 for (c
= gfc_constructor_first (e
->value
.constructor
);
6959 c
; c
= gfc_constructor_next (c
))
6961 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
6962 if (tmp
== &gfc_bad_expr
)
6964 gfc_free_expr (result
);
6965 return &gfc_bad_expr
;
6970 gfc_free_expr (result
);
6974 gfc_constructor_append_expr (&result
->value
.constructor
,
6986 gfc_simplify_compiler_options (void)
6991 str
= gfc_get_option_string ();
6992 result
= gfc_get_character_expr (gfc_default_character_kind
,
6993 &gfc_current_locus
, str
, strlen (str
));
7000 gfc_simplify_compiler_version (void)
7005 len
= strlen ("GCC version ") + strlen (version_string
);
7006 buffer
= XALLOCAVEC (char, len
+ 1);
7007 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
7008 return gfc_get_character_expr (gfc_default_character_kind
,
7009 &gfc_current_locus
, buffer
, len
);