1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2014 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "intrinsic.h"
28 #include "target-memory.h"
29 #include "constructor.h"
30 #include "tm.h" /* For BITS_PER_UNIT. */
31 #include "version.h" /* For version_string. */
34 gfc_expr gfc_bad_expr
;
36 static gfc_expr
*simplify_size (gfc_expr
*, gfc_expr
*, int);
39 /* Note that 'simplification' is not just transforming expressions.
40 For functions that are not simplified at compile time, range
41 checking is done if possible.
43 The return convention is that each simplification function returns:
45 A new expression node corresponding to the simplified arguments.
46 The original arguments are destroyed by the caller, and must not
47 be a part of the new expression.
49 NULL pointer indicating that no simplification was possible and
50 the original expression should remain intact.
52 An expression pointer to gfc_bad_expr (a static placeholder)
53 indicating that some error has prevented simplification. The
54 error is generated within the function and should be propagated
57 By the time a simplification function gets control, it has been
58 decided that the function call is really supposed to be the
59 intrinsic. No type checking is strictly necessary, since only
60 valid types will be passed on. On the other hand, a simplification
61 subroutine may have to look at the type of an argument as part of
64 Array arguments are only passed to these subroutines that implement
65 the simplification of transformational intrinsics.
67 The functions in this file don't have much comment with them, but
68 everything is reasonably straight-forward. The Standard, chapter 13
69 is the best comment you'll find for this file anyway. */
71 /* Range checks an expression node. If all goes well, returns the
72 node, otherwise returns &gfc_bad_expr and frees the node. */
75 range_check (gfc_expr
*result
, const char *name
)
80 if (result
->expr_type
!= EXPR_CONSTANT
)
83 switch (gfc_range_check (result
))
89 gfc_error ("Result of %s overflows its kind at %L", name
,
94 gfc_error ("Result of %s underflows its kind at %L", name
,
99 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
103 gfc_error ("Result of %s gives range error for its kind at %L", name
,
108 gfc_free_expr (result
);
109 return &gfc_bad_expr
;
113 /* A helper function that gets an optional and possibly missing
114 kind parameter. Returns the kind, -1 if something went wrong. */
117 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
124 if (k
->expr_type
!= EXPR_CONSTANT
)
126 gfc_error ("KIND parameter of %s at %L must be an initialization "
127 "expression", name
, &k
->where
);
131 if (gfc_extract_int (k
, &kind
) != NULL
132 || gfc_validate_kind (type
, kind
, true) < 0)
134 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
142 /* Converts an mpz_t signed variable into an unsigned one, assuming
143 two's complement representations and a binary width of bitsize.
144 The conversion is a no-op unless x is negative; otherwise, it can
145 be accomplished by masking out the high bits. */
148 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
154 /* Confirm that no bits above the signed range are unset if we
155 are doing range checking. */
156 if (gfc_option
.flag_range_check
!= 0)
157 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
159 mpz_init_set_ui (mask
, 1);
160 mpz_mul_2exp (mask
, mask
, bitsize
);
161 mpz_sub_ui (mask
, mask
, 1);
163 mpz_and (x
, x
, mask
);
169 /* Confirm that no bits above the signed range are set. */
170 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
175 /* Converts an mpz_t unsigned variable into a signed one, assuming
176 two's complement representations and a binary width of bitsize.
177 If the bitsize-1 bit is set, this is taken as a sign bit and
178 the number is converted to the corresponding negative number. */
181 gfc_convert_mpz_to_signed (mpz_t x
, int bitsize
)
185 /* Confirm that no bits above the unsigned range are set if we are
186 doing range checking. */
187 if (gfc_option
.flag_range_check
!= 0)
188 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
190 if (mpz_tstbit (x
, bitsize
- 1) == 1)
192 mpz_init_set_ui (mask
, 1);
193 mpz_mul_2exp (mask
, mask
, bitsize
);
194 mpz_sub_ui (mask
, mask
, 1);
196 /* We negate the number by hand, zeroing the high bits, that is
197 make it the corresponding positive number, and then have it
198 negated by GMP, giving the correct representation of the
201 mpz_add_ui (x
, x
, 1);
202 mpz_and (x
, x
, mask
);
211 /* In-place convert BOZ to REAL of the specified kind. */
214 convert_boz (gfc_expr
*x
, int kind
)
216 if (x
&& x
->ts
.type
== BT_INTEGER
&& x
->is_boz
)
223 if (!gfc_convert_boz (x
, &ts
))
224 return &gfc_bad_expr
;
231 /* Test that the expression is an constant array. */
234 is_constant_array_expr (gfc_expr
*e
)
241 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
244 for (c
= gfc_constructor_first (e
->value
.constructor
);
245 c
; c
= gfc_constructor_next (c
))
246 if (c
->expr
->expr_type
!= EXPR_CONSTANT
247 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
254 /* Initialize a transformational result expression with a given value. */
257 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
259 if (e
&& e
->expr_type
== EXPR_ARRAY
)
261 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
264 init_result_expr (ctor
->expr
, init
, array
);
265 ctor
= gfc_constructor_next (ctor
);
268 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
270 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
277 e
->value
.logical
= (init
? 1 : 0);
282 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
283 else if (init
== INT_MAX
)
284 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
286 mpz_set_si (e
->value
.integer
, init
);
292 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
293 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
295 else if (init
== INT_MAX
)
296 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
298 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
302 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
308 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
309 gfc_extract_int (len
, &length
);
310 string
= gfc_get_wide_string (length
+ 1);
311 gfc_wide_memset (string
, 0, length
);
313 else if (init
== INT_MAX
)
315 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
316 gfc_extract_int (len
, &length
);
317 string
= gfc_get_wide_string (length
+ 1);
318 gfc_wide_memset (string
, 255, length
);
323 string
= gfc_get_wide_string (1);
326 string
[length
] = '\0';
327 e
->value
.character
.length
= length
;
328 e
->value
.character
.string
= string
;
340 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
341 if conj_a is true, the matrix_a is complex conjugated. */
344 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
345 gfc_expr
*matrix_b
, int stride_b
, int offset_b
,
348 gfc_expr
*result
, *a
, *b
, *c
;
350 result
= gfc_get_constant_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
352 init_result_expr (result
, 0, NULL
);
354 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
355 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
358 /* Copying of expressions is required as operands are free'd
359 by the gfc_arith routines. */
360 switch (result
->ts
.type
)
363 result
= gfc_or (result
,
364 gfc_and (gfc_copy_expr (a
),
371 if (conj_a
&& a
->ts
.type
== BT_COMPLEX
)
372 c
= gfc_simplify_conjg (a
);
374 c
= gfc_copy_expr (a
);
375 result
= gfc_add (result
, gfc_multiply (c
, gfc_copy_expr (b
)));
382 offset_a
+= stride_a
;
383 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
385 offset_b
+= stride_b
;
386 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
393 /* Build a result expression for transformational intrinsics,
397 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
398 int kind
, locus
* where
)
403 if (!dim
|| array
->rank
== 1)
404 return gfc_get_constant_expr (type
, kind
, where
);
406 result
= gfc_get_array_expr (type
, kind
, where
);
407 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
408 result
->rank
= array
->rank
- 1;
410 /* gfc_array_size() would count the number of elements in the constructor,
411 we have not built those yet. */
413 for (i
= 0; i
< result
->rank
; ++i
)
414 nelem
*= mpz_get_ui (result
->shape
[i
]);
416 for (i
= 0; i
< nelem
; ++i
)
418 gfc_constructor_append_expr (&result
->value
.constructor
,
419 gfc_get_constant_expr (type
, kind
, where
),
427 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
429 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
430 of COUNT intrinsic is .TRUE..
432 Interface and implementation mimics arith functions as
433 gfc_add, gfc_multiply, etc. */
435 static gfc_expr
* gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
439 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
440 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
441 gcc_assert (op2
->value
.logical
);
443 result
= gfc_copy_expr (op1
);
444 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
452 /* Transforms an ARRAY with operation OP, according to MASK, to a
453 scalar RESULT. E.g. called if
455 REAL, PARAMETER :: array(n, m) = ...
456 REAL, PARAMETER :: s = SUM(array)
458 where OP == gfc_add(). */
461 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
462 transformational_op op
)
465 gfc_constructor
*array_ctor
, *mask_ctor
;
467 /* Shortcut for constant .FALSE. MASK. */
469 && mask
->expr_type
== EXPR_CONSTANT
470 && !mask
->value
.logical
)
473 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
475 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
476 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
480 a
= array_ctor
->expr
;
481 array_ctor
= gfc_constructor_next (array_ctor
);
483 /* A constant MASK equals .TRUE. here and can be ignored. */
487 mask_ctor
= gfc_constructor_next (mask_ctor
);
488 if (!m
->value
.logical
)
492 result
= op (result
, gfc_copy_expr (a
));
498 /* Transforms an ARRAY with operation OP, according to MASK, to an
499 array RESULT. E.g. called if
501 REAL, PARAMETER :: array(n, m) = ...
502 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
504 where OP == gfc_multiply(). The result might be post processed using post_op. */
507 simplify_transformation_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*dim
,
508 gfc_expr
*mask
, transformational_op op
,
509 transformational_op post_op
)
512 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
513 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
514 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
516 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
517 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
518 tmpstride
[GFC_MAX_DIMENSIONS
];
520 /* Shortcut for constant .FALSE. MASK. */
522 && mask
->expr_type
== EXPR_CONSTANT
523 && !mask
->value
.logical
)
526 /* Build an indexed table for array element expressions to minimize
527 linked-list traversal. Masked elements are set to NULL. */
528 gfc_array_size (array
, &size
);
529 arraysize
= mpz_get_ui (size
);
532 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
534 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
536 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
537 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
539 for (i
= 0; i
< arraysize
; ++i
)
541 arrayvec
[i
] = array_ctor
->expr
;
542 array_ctor
= gfc_constructor_next (array_ctor
);
546 if (!mask_ctor
->expr
->value
.logical
)
549 mask_ctor
= gfc_constructor_next (mask_ctor
);
553 /* Same for the result expression. */
554 gfc_array_size (result
, &size
);
555 resultsize
= mpz_get_ui (size
);
558 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
559 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
560 for (i
= 0; i
< resultsize
; ++i
)
562 resultvec
[i
] = result_ctor
->expr
;
563 result_ctor
= gfc_constructor_next (result_ctor
);
566 gfc_extract_int (dim
, &dim_index
);
567 dim_index
-= 1; /* zero-base index */
571 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
574 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
577 dim_extent
= mpz_get_si (array
->shape
[i
]);
578 dim_stride
= tmpstride
[i
];
582 extent
[n
] = mpz_get_si (array
->shape
[i
]);
583 sstride
[n
] = tmpstride
[i
];
584 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
593 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
595 *dest
= op (*dest
, gfc_copy_expr (*src
));
602 while (!done
&& count
[n
] == extent
[n
])
605 base
-= sstride
[n
] * extent
[n
];
606 dest
-= dstride
[n
] * extent
[n
];
609 if (n
< result
->rank
)
620 /* Place updated expression in result constructor. */
621 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
622 for (i
= 0; i
< resultsize
; ++i
)
625 result_ctor
->expr
= post_op (result_ctor
->expr
, resultvec
[i
]);
627 result_ctor
->expr
= resultvec
[i
];
628 result_ctor
= gfc_constructor_next (result_ctor
);
638 simplify_transformation (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
639 int init_val
, transformational_op op
)
643 if (!is_constant_array_expr (array
)
644 || !gfc_is_constant_expr (dim
))
648 && !is_constant_array_expr (mask
)
649 && mask
->expr_type
!= EXPR_CONSTANT
)
652 result
= transformational_result (array
, dim
, array
->ts
.type
,
653 array
->ts
.kind
, &array
->where
);
654 init_result_expr (result
, init_val
, NULL
);
656 return !dim
|| array
->rank
== 1 ?
657 simplify_transformation_to_scalar (result
, array
, mask
, op
) :
658 simplify_transformation_to_array (result
, array
, dim
, mask
, op
, NULL
);
662 /********************** Simplification functions *****************************/
665 gfc_simplify_abs (gfc_expr
*e
)
669 if (e
->expr_type
!= EXPR_CONSTANT
)
675 result
= gfc_get_constant_expr (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
676 mpz_abs (result
->value
.integer
, e
->value
.integer
);
677 return range_check (result
, "IABS");
680 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
681 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
682 return range_check (result
, "ABS");
685 gfc_set_model_kind (e
->ts
.kind
);
686 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
687 mpc_abs (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
688 return range_check (result
, "CABS");
691 gfc_internal_error ("gfc_simplify_abs(): Bad type");
697 simplify_achar_char (gfc_expr
*e
, gfc_expr
*k
, const char *name
, bool ascii
)
701 bool too_large
= false;
703 if (e
->expr_type
!= EXPR_CONSTANT
)
706 kind
= get_kind (BT_CHARACTER
, k
, name
, gfc_default_character_kind
);
708 return &gfc_bad_expr
;
710 if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
712 gfc_error ("Argument of %s function at %L is negative", name
,
714 return &gfc_bad_expr
;
717 if (ascii
&& gfc_option
.warn_surprising
718 && mpz_cmp_si (e
->value
.integer
, 127) > 0)
719 gfc_warning ("Argument of %s function at %L outside of range [0,127]",
722 if (kind
== 1 && mpz_cmp_si (e
->value
.integer
, 255) > 0)
727 mpz_init_set_ui (t
, 2);
728 mpz_pow_ui (t
, t
, 32);
729 mpz_sub_ui (t
, t
, 1);
730 if (mpz_cmp (e
->value
.integer
, t
) > 0)
737 gfc_error ("Argument of %s function at %L is too large for the "
738 "collating sequence of kind %d", name
, &e
->where
, kind
);
739 return &gfc_bad_expr
;
742 result
= gfc_get_character_expr (kind
, &e
->where
, NULL
, 1);
743 result
->value
.character
.string
[0] = mpz_get_ui (e
->value
.integer
);
750 /* We use the processor's collating sequence, because all
751 systems that gfortran currently works on are ASCII. */
754 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
756 return simplify_achar_char (e
, k
, "ACHAR", true);
761 gfc_simplify_acos (gfc_expr
*x
)
765 if (x
->expr_type
!= EXPR_CONSTANT
)
771 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
772 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
774 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
776 return &gfc_bad_expr
;
778 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
779 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
783 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
784 mpc_acos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
788 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
791 return range_check (result
, "ACOS");
795 gfc_simplify_acosh (gfc_expr
*x
)
799 if (x
->expr_type
!= EXPR_CONSTANT
)
805 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
807 gfc_error ("Argument of ACOSH at %L must not be less than 1",
809 return &gfc_bad_expr
;
812 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
813 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
817 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
818 mpc_acosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
822 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
825 return range_check (result
, "ACOSH");
829 gfc_simplify_adjustl (gfc_expr
*e
)
835 if (e
->expr_type
!= EXPR_CONSTANT
)
838 len
= e
->value
.character
.length
;
840 for (count
= 0, i
= 0; i
< len
; ++i
)
842 ch
= e
->value
.character
.string
[i
];
848 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
849 for (i
= 0; i
< len
- count
; ++i
)
850 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
857 gfc_simplify_adjustr (gfc_expr
*e
)
863 if (e
->expr_type
!= EXPR_CONSTANT
)
866 len
= e
->value
.character
.length
;
868 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
870 ch
= e
->value
.character
.string
[i
];
876 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
877 for (i
= 0; i
< count
; ++i
)
878 result
->value
.character
.string
[i
] = ' ';
880 for (i
= count
; i
< len
; ++i
)
881 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
888 gfc_simplify_aimag (gfc_expr
*e
)
892 if (e
->expr_type
!= EXPR_CONSTANT
)
895 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
896 mpfr_set (result
->value
.real
, mpc_imagref (e
->value
.complex), GFC_RND_MODE
);
898 return range_check (result
, "AIMAG");
903 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
905 gfc_expr
*rtrunc
, *result
;
908 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
910 return &gfc_bad_expr
;
912 if (e
->expr_type
!= EXPR_CONSTANT
)
915 rtrunc
= gfc_copy_expr (e
);
916 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
918 result
= gfc_real2real (rtrunc
, kind
);
920 gfc_free_expr (rtrunc
);
922 return range_check (result
, "AINT");
927 gfc_simplify_all (gfc_expr
*mask
, gfc_expr
*dim
)
929 return simplify_transformation (mask
, dim
, NULL
, true, gfc_and
);
934 gfc_simplify_dint (gfc_expr
*e
)
936 gfc_expr
*rtrunc
, *result
;
938 if (e
->expr_type
!= EXPR_CONSTANT
)
941 rtrunc
= gfc_copy_expr (e
);
942 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
944 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
946 gfc_free_expr (rtrunc
);
948 return range_check (result
, "DINT");
953 gfc_simplify_dreal (gfc_expr
*e
)
955 gfc_expr
*result
= NULL
;
957 if (e
->expr_type
!= EXPR_CONSTANT
)
960 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
961 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
963 return range_check (result
, "DREAL");
968 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
973 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
975 return &gfc_bad_expr
;
977 if (e
->expr_type
!= EXPR_CONSTANT
)
980 result
= gfc_get_constant_expr (e
->ts
.type
, kind
, &e
->where
);
981 mpfr_round (result
->value
.real
, e
->value
.real
);
983 return range_check (result
, "ANINT");
988 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
993 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
996 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1001 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
1002 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1003 return range_check (result
, "AND");
1006 return gfc_get_logical_expr (kind
, &x
->where
,
1007 x
->value
.logical
&& y
->value
.logical
);
1016 gfc_simplify_any (gfc_expr
*mask
, gfc_expr
*dim
)
1018 return simplify_transformation (mask
, dim
, NULL
, false, gfc_or
);
1023 gfc_simplify_dnint (gfc_expr
*e
)
1027 if (e
->expr_type
!= EXPR_CONSTANT
)
1030 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &e
->where
);
1031 mpfr_round (result
->value
.real
, e
->value
.real
);
1033 return range_check (result
, "DNINT");
1038 gfc_simplify_asin (gfc_expr
*x
)
1042 if (x
->expr_type
!= EXPR_CONSTANT
)
1048 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1049 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1051 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1053 return &gfc_bad_expr
;
1055 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1056 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1060 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1061 mpc_asin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1065 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1068 return range_check (result
, "ASIN");
1073 gfc_simplify_asinh (gfc_expr
*x
)
1077 if (x
->expr_type
!= EXPR_CONSTANT
)
1080 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1085 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1089 mpc_asinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1093 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1096 return range_check (result
, "ASINH");
1101 gfc_simplify_atan (gfc_expr
*x
)
1105 if (x
->expr_type
!= EXPR_CONSTANT
)
1108 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1113 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1117 mpc_atan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1121 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1124 return range_check (result
, "ATAN");
1129 gfc_simplify_atanh (gfc_expr
*x
)
1133 if (x
->expr_type
!= EXPR_CONSTANT
)
1139 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
1140 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
1142 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1144 return &gfc_bad_expr
;
1146 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1147 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1151 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1152 mpc_atanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1156 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1159 return range_check (result
, "ATANH");
1164 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1168 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1171 if (mpfr_sgn (y
->value
.real
) == 0 && mpfr_sgn (x
->value
.real
) == 0)
1173 gfc_error ("If first argument of ATAN2 %L is zero, then the "
1174 "second argument must not be zero", &x
->where
);
1175 return &gfc_bad_expr
;
1178 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1179 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1181 return range_check (result
, "ATAN2");
1186 gfc_simplify_bessel_j0 (gfc_expr
*x
)
1190 if (x
->expr_type
!= EXPR_CONSTANT
)
1193 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1194 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1196 return range_check (result
, "BESSEL_J0");
1201 gfc_simplify_bessel_j1 (gfc_expr
*x
)
1205 if (x
->expr_type
!= EXPR_CONSTANT
)
1208 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1209 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1211 return range_check (result
, "BESSEL_J1");
1216 gfc_simplify_bessel_jn (gfc_expr
*order
, gfc_expr
*x
)
1221 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1224 n
= mpz_get_si (order
->value
.integer
);
1225 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1226 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1228 return range_check (result
, "BESSEL_JN");
1232 /* Simplify transformational form of JN and YN. */
1235 gfc_simplify_bessel_n2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
,
1242 mpfr_t x2rev
, last1
, last2
;
1244 if (x
->expr_type
!= EXPR_CONSTANT
|| order1
->expr_type
!= EXPR_CONSTANT
1245 || order2
->expr_type
!= EXPR_CONSTANT
)
1248 n1
= mpz_get_si (order1
->value
.integer
);
1249 n2
= mpz_get_si (order2
->value
.integer
);
1250 result
= gfc_get_array_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1252 result
->shape
= gfc_get_shape (1);
1253 mpz_init_set_ui (result
->shape
[0], MAX (n2
-n1
+1, 0));
1258 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1259 YN(N, 0.0) = -Inf. */
1261 if (mpfr_cmp_ui (x
->value
.real
, 0.0) == 0)
1263 if (!jn
&& gfc_option
.flag_range_check
)
1265 gfc_error ("Result of BESSEL_YN is -INF at %L", &result
->where
);
1266 gfc_free_expr (result
);
1267 return &gfc_bad_expr
;
1272 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1273 mpfr_set_ui (e
->value
.real
, 1, GFC_RND_MODE
);
1274 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1279 for (i
= n1
; i
<= n2
; i
++)
1281 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1283 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
1285 mpfr_set_inf (e
->value
.real
, -1);
1286 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1293 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1294 are stable for downward recursion and Neumann functions are stable
1295 for upward recursion. It is
1297 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1298 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1299 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1301 gfc_set_model_kind (x
->ts
.kind
);
1303 /* Get first recursion anchor. */
1307 mpfr_jn (last1
, n2
, x
->value
.real
, GFC_RND_MODE
);
1309 mpfr_yn (last1
, n1
, x
->value
.real
, GFC_RND_MODE
);
1311 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1312 mpfr_set (e
->value
.real
, last1
, GFC_RND_MODE
);
1313 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1317 gfc_free_expr (result
);
1318 return &gfc_bad_expr
;
1320 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1328 /* Get second recursion anchor. */
1332 mpfr_jn (last2
, n2
-1, x
->value
.real
, GFC_RND_MODE
);
1334 mpfr_yn (last2
, n1
+1, x
->value
.real
, GFC_RND_MODE
);
1336 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1337 mpfr_set (e
->value
.real
, last2
, GFC_RND_MODE
);
1338 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1343 gfc_free_expr (result
);
1344 return &gfc_bad_expr
;
1347 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
, -2);
1349 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1358 /* Start actual recursion. */
1361 mpfr_ui_div (x2rev
, 2, x
->value
.real
, GFC_RND_MODE
);
1363 for (i
= 2; i
<= n2
-n1
; i
++)
1365 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1367 /* Special case: For YN, if the previous N gave -INF, set
1368 also N+1 to -INF. */
1369 if (!jn
&& !gfc_option
.flag_range_check
&& mpfr_inf_p (last2
))
1371 mpfr_set_inf (e
->value
.real
, -1);
1372 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1377 mpfr_mul_si (e
->value
.real
, x2rev
, jn
? (n2
-i
+1) : (n1
+i
-1),
1379 mpfr_mul (e
->value
.real
, e
->value
.real
, last2
, GFC_RND_MODE
);
1380 mpfr_sub (e
->value
.real
, e
->value
.real
, last1
, GFC_RND_MODE
);
1382 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1384 /* Range_check frees "e" in that case. */
1390 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
,
1393 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1395 mpfr_set (last1
, last2
, GFC_RND_MODE
);
1396 mpfr_set (last2
, e
->value
.real
, GFC_RND_MODE
);
1409 gfc_free_expr (result
);
1410 return &gfc_bad_expr
;
1415 gfc_simplify_bessel_jn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1417 return gfc_simplify_bessel_n2 (order1
, order2
, x
, true);
1422 gfc_simplify_bessel_y0 (gfc_expr
*x
)
1426 if (x
->expr_type
!= EXPR_CONSTANT
)
1429 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1430 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1432 return range_check (result
, "BESSEL_Y0");
1437 gfc_simplify_bessel_y1 (gfc_expr
*x
)
1441 if (x
->expr_type
!= EXPR_CONSTANT
)
1444 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1445 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1447 return range_check (result
, "BESSEL_Y1");
1452 gfc_simplify_bessel_yn (gfc_expr
*order
, gfc_expr
*x
)
1457 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1460 n
= mpz_get_si (order
->value
.integer
);
1461 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1462 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1464 return range_check (result
, "BESSEL_YN");
1469 gfc_simplify_bessel_yn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1471 return gfc_simplify_bessel_n2 (order1
, order2
, x
, false);
1476 gfc_simplify_bit_size (gfc_expr
*e
)
1478 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1479 return gfc_get_int_expr (e
->ts
.kind
, &e
->where
,
1480 gfc_integer_kinds
[i
].bit_size
);
1485 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
1489 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
1492 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
1493 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
, false);
1495 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
,
1496 mpz_tstbit (e
->value
.integer
, b
));
1501 compare_bitwise (gfc_expr
*i
, gfc_expr
*j
)
1506 gcc_assert (i
->ts
.type
== BT_INTEGER
);
1507 gcc_assert (j
->ts
.type
== BT_INTEGER
);
1509 mpz_init_set (x
, i
->value
.integer
);
1510 k
= gfc_validate_kind (i
->ts
.type
, i
->ts
.kind
, false);
1511 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
1513 mpz_init_set (y
, j
->value
.integer
);
1514 k
= gfc_validate_kind (j
->ts
.type
, j
->ts
.kind
, false);
1515 convert_mpz_to_unsigned (y
, gfc_integer_kinds
[k
].bit_size
);
1517 res
= mpz_cmp (x
, y
);
1525 gfc_simplify_bge (gfc_expr
*i
, gfc_expr
*j
)
1527 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1530 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1531 compare_bitwise (i
, j
) >= 0);
1536 gfc_simplify_bgt (gfc_expr
*i
, gfc_expr
*j
)
1538 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1541 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1542 compare_bitwise (i
, j
) > 0);
1547 gfc_simplify_ble (gfc_expr
*i
, gfc_expr
*j
)
1549 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1552 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1553 compare_bitwise (i
, j
) <= 0);
1558 gfc_simplify_blt (gfc_expr
*i
, gfc_expr
*j
)
1560 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1563 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1564 compare_bitwise (i
, j
) < 0);
1569 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
1571 gfc_expr
*ceil
, *result
;
1574 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
1576 return &gfc_bad_expr
;
1578 if (e
->expr_type
!= EXPR_CONSTANT
)
1581 ceil
= gfc_copy_expr (e
);
1582 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
1584 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
1585 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
, &e
->where
);
1587 gfc_free_expr (ceil
);
1589 return range_check (result
, "CEILING");
1594 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
1596 return simplify_achar_char (e
, k
, "CHAR", false);
1600 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1603 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
1607 if (convert_boz (x
, kind
) == &gfc_bad_expr
)
1608 return &gfc_bad_expr
;
1610 if (convert_boz (y
, kind
) == &gfc_bad_expr
)
1611 return &gfc_bad_expr
;
1613 if (x
->expr_type
!= EXPR_CONSTANT
1614 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1617 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &x
->where
);
1622 mpc_set_z (result
->value
.complex, x
->value
.integer
, GFC_MPC_RND_MODE
);
1626 mpc_set_fr (result
->value
.complex, x
->value
.real
, GFC_RND_MODE
);
1630 mpc_set (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1634 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1638 return range_check (result
, name
);
1643 mpfr_set_z (mpc_imagref (result
->value
.complex),
1644 y
->value
.integer
, GFC_RND_MODE
);
1648 mpfr_set (mpc_imagref (result
->value
.complex),
1649 y
->value
.real
, GFC_RND_MODE
);
1653 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1656 return range_check (result
, name
);
1661 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
1665 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_complex_kind
);
1667 return &gfc_bad_expr
;
1669 return simplify_cmplx ("CMPLX", x
, y
, kind
);
1674 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
1678 if (x
->ts
.type
== BT_INTEGER
&& y
->ts
.type
== BT_INTEGER
)
1679 kind
= gfc_default_complex_kind
;
1680 else if (x
->ts
.type
== BT_REAL
|| y
->ts
.type
== BT_INTEGER
)
1682 else if (x
->ts
.type
== BT_INTEGER
|| y
->ts
.type
== BT_REAL
)
1684 else if (x
->ts
.type
== BT_REAL
&& y
->ts
.type
== BT_REAL
)
1685 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
1689 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1694 gfc_simplify_conjg (gfc_expr
*e
)
1698 if (e
->expr_type
!= EXPR_CONSTANT
)
1701 result
= gfc_copy_expr (e
);
1702 mpc_conj (result
->value
.complex, result
->value
.complex, GFC_MPC_RND_MODE
);
1704 return range_check (result
, "CONJG");
1709 gfc_simplify_cos (gfc_expr
*x
)
1713 if (x
->expr_type
!= EXPR_CONSTANT
)
1716 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1721 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1725 gfc_set_model_kind (x
->ts
.kind
);
1726 mpc_cos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1730 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1733 return range_check (result
, "COS");
1738 gfc_simplify_cosh (gfc_expr
*x
)
1742 if (x
->expr_type
!= EXPR_CONSTANT
)
1745 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1750 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1754 mpc_cosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1761 return range_check (result
, "COSH");
1766 gfc_simplify_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1770 if (!is_constant_array_expr (mask
)
1771 || !gfc_is_constant_expr (dim
)
1772 || !gfc_is_constant_expr (kind
))
1775 result
= transformational_result (mask
, dim
,
1777 get_kind (BT_INTEGER
, kind
, "COUNT",
1778 gfc_default_integer_kind
),
1781 init_result_expr (result
, 0, NULL
);
1783 /* Passing MASK twice, once as data array, once as mask.
1784 Whenever gfc_count is called, '1' is added to the result. */
1785 return !dim
|| mask
->rank
== 1 ?
1786 simplify_transformation_to_scalar (result
, mask
, mask
, gfc_count
) :
1787 simplify_transformation_to_array (result
, mask
, dim
, mask
, gfc_count
, NULL
);
1792 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1794 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
1799 gfc_simplify_dble (gfc_expr
*e
)
1801 gfc_expr
*result
= NULL
;
1803 if (e
->expr_type
!= EXPR_CONSTANT
)
1806 if (convert_boz (e
, gfc_default_double_kind
) == &gfc_bad_expr
)
1807 return &gfc_bad_expr
;
1809 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
1810 if (result
== &gfc_bad_expr
)
1811 return &gfc_bad_expr
;
1813 return range_check (result
, "DBLE");
1818 gfc_simplify_digits (gfc_expr
*x
)
1822 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1827 digits
= gfc_integer_kinds
[i
].digits
;
1832 digits
= gfc_real_kinds
[i
].digits
;
1839 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
1844 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
1849 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1852 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1853 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
1858 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
1859 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1861 mpz_set_ui (result
->value
.integer
, 0);
1866 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
1867 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
1870 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1875 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1878 return range_check (result
, "DIM");
1883 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1885 if (!is_constant_array_expr (vector_a
)
1886 || !is_constant_array_expr (vector_b
))
1889 gcc_assert (vector_a
->rank
== 1);
1890 gcc_assert (vector_b
->rank
== 1);
1891 gcc_assert (gfc_compare_types (&vector_a
->ts
, &vector_b
->ts
));
1893 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
1898 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
1900 gfc_expr
*a1
, *a2
, *result
;
1902 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1905 a1
= gfc_real2real (x
, gfc_default_double_kind
);
1906 a2
= gfc_real2real (y
, gfc_default_double_kind
);
1908 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
1909 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
1914 return range_check (result
, "DPROD");
1919 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
1923 int i
, k
, size
, shift
;
1925 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
1926 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
1929 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
1930 size
= gfc_integer_kinds
[k
].bit_size
;
1932 gfc_extract_int (shiftarg
, &shift
);
1934 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
1936 shift
= size
- shift
;
1938 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
1939 mpz_set_ui (result
->value
.integer
, 0);
1941 for (i
= 0; i
< shift
; i
++)
1942 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
1943 mpz_setbit (result
->value
.integer
, i
);
1945 for (i
= 0; i
< size
- shift
; i
++)
1946 if (mpz_tstbit (arg1
->value
.integer
, i
))
1947 mpz_setbit (result
->value
.integer
, shift
+ i
);
1949 /* Convert to a signed value. */
1950 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
1957 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
1959 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
1964 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
1966 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
1971 gfc_simplify_erf (gfc_expr
*x
)
1975 if (x
->expr_type
!= EXPR_CONSTANT
)
1978 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1979 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1981 return range_check (result
, "ERF");
1986 gfc_simplify_erfc (gfc_expr
*x
)
1990 if (x
->expr_type
!= EXPR_CONSTANT
)
1993 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1994 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1996 return range_check (result
, "ERFC");
2000 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2002 #define MAX_ITER 200
2003 #define ARG_LIMIT 12
2005 /* Calculate ERFC_SCALED directly by its definition:
2007 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2009 using a large precision for intermediate results. This is used for all
2010 but large values of the argument. */
2012 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2017 prec
= mpfr_get_default_prec ();
2018 mpfr_set_default_prec (10 * prec
);
2023 mpfr_set (a
, arg
, GFC_RND_MODE
);
2024 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2025 mpfr_exp (b
, b
, GFC_RND_MODE
);
2026 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2027 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2029 mpfr_set (res
, a
, GFC_RND_MODE
);
2030 mpfr_set_default_prec (prec
);
2036 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2038 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2039 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2042 This is used for large values of the argument. Intermediate calculations
2043 are performed with twice the precision. We don't do a fixed number of
2044 iterations of the sum, but stop when it has converged to the required
2047 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2049 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2054 prec
= mpfr_get_default_prec ();
2055 mpfr_set_default_prec (2 * prec
);
2065 mpfr_init (sumtrunc
);
2066 mpfr_set_prec (oldsum
, prec
);
2067 mpfr_set_prec (sumtrunc
, prec
);
2069 mpfr_set (x
, arg
, GFC_RND_MODE
);
2070 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2071 mpz_set_ui (num
, 1);
2073 mpfr_set (u
, x
, GFC_RND_MODE
);
2074 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2075 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2076 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2078 for (i
= 1; i
< MAX_ITER
; i
++)
2080 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2082 mpz_mul_ui (num
, num
, 2 * i
- 1);
2085 mpfr_set (w
, u
, GFC_RND_MODE
);
2086 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2088 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2089 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2091 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2093 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2094 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2098 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2100 gcc_assert (i
< MAX_ITER
);
2102 /* Divide by x * sqrt(Pi). */
2103 mpfr_const_pi (u
, GFC_RND_MODE
);
2104 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2105 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2106 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2108 mpfr_set (res
, sum
, GFC_RND_MODE
);
2109 mpfr_set_default_prec (prec
);
2111 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2117 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2121 if (x
->expr_type
!= EXPR_CONSTANT
)
2124 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2125 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2126 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2128 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2130 return range_check (result
, "ERFC_SCALED");
2138 gfc_simplify_epsilon (gfc_expr
*e
)
2143 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2145 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2146 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2148 return range_check (result
, "EPSILON");
2153 gfc_simplify_exp (gfc_expr
*x
)
2157 if (x
->expr_type
!= EXPR_CONSTANT
)
2160 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2165 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2169 gfc_set_model_kind (x
->ts
.kind
);
2170 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2174 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2177 return range_check (result
, "EXP");
2182 gfc_simplify_exponent (gfc_expr
*x
)
2187 if (x
->expr_type
!= EXPR_CONSTANT
)
2190 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2193 gfc_set_model (x
->value
.real
);
2195 if (mpfr_sgn (x
->value
.real
) == 0)
2197 mpz_set_ui (result
->value
.integer
, 0);
2201 i
= (int) mpfr_get_exp (x
->value
.real
);
2202 mpz_set_si (result
->value
.integer
, i
);
2204 return range_check (result
, "EXPONENT");
2209 gfc_simplify_float (gfc_expr
*a
)
2213 if (a
->expr_type
!= EXPR_CONSTANT
)
2218 if (convert_boz (a
, gfc_default_real_kind
) == &gfc_bad_expr
)
2219 return &gfc_bad_expr
;
2221 result
= gfc_copy_expr (a
);
2224 result
= gfc_int2real (a
, gfc_default_real_kind
);
2226 return range_check (result
, "FLOAT");
2231 is_last_ref_vtab (gfc_expr
*e
)
2234 gfc_component
*comp
= NULL
;
2236 if (e
->expr_type
!= EXPR_VARIABLE
)
2239 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2240 if (ref
->type
== REF_COMPONENT
)
2241 comp
= ref
->u
.c
.component
;
2243 if (!e
->ref
|| !comp
)
2244 return e
->symtree
->n
.sym
->attr
.vtab
;
2246 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
2254 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
2256 /* Avoid simplification of resolved symbols. */
2257 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
2260 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
2261 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2262 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2265 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
2268 /* Return .false. if the dynamic type can never be the same. */
2269 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
2270 && !gfc_type_is_extension_of
2271 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2272 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
2273 && !gfc_type_is_extension_of
2274 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
2275 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
2276 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
2277 && !gfc_type_is_extension_of
2279 mold
->ts
.u
.derived
->components
->ts
.u
.derived
)
2280 && !gfc_type_is_extension_of
2281 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2283 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
2284 && !gfc_type_is_extension_of
2285 (mold
->ts
.u
.derived
,
2286 a
->ts
.u
.derived
->components
->ts
.u
.derived
)))
2287 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2289 if (mold
->ts
.type
== BT_DERIVED
2290 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2291 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
2292 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
2299 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
2301 /* Avoid simplification of resolved symbols. */
2302 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
2305 /* Return .false. if the dynamic type can never be the
2307 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
2308 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
2309 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
2310 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
2311 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2313 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
2316 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2317 gfc_compare_derived_types (a
->ts
.u
.derived
,
2323 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
2329 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
2331 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2333 if (e
->expr_type
!= EXPR_CONSTANT
)
2336 gfc_set_model_kind (kind
);
2339 mpfr_floor (floor
, e
->value
.real
);
2341 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
2342 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
2346 return range_check (result
, "FLOOR");
2351 gfc_simplify_fraction (gfc_expr
*x
)
2355 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2356 mpfr_t absv
, exp
, pow2
;
2361 if (x
->expr_type
!= EXPR_CONSTANT
)
2364 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
2366 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2368 /* MPFR versions before 3.1.0 do not include mpfr_frexp.
2369 TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
2371 if (mpfr_sgn (x
->value
.real
) == 0)
2373 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2377 gfc_set_model_kind (x
->ts
.kind
);
2382 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
2383 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
2385 mpfr_trunc (exp
, exp
);
2386 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
2388 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
2390 mpfr_div (result
->value
.real
, x
->value
.real
, pow2
, GFC_RND_MODE
);
2392 mpfr_clears (exp
, absv
, pow2
, NULL
);
2396 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2400 return range_check (result
, "FRACTION");
2405 gfc_simplify_gamma (gfc_expr
*x
)
2409 if (x
->expr_type
!= EXPR_CONSTANT
)
2412 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2413 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2415 return range_check (result
, "GAMMA");
2420 gfc_simplify_huge (gfc_expr
*e
)
2425 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2426 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2431 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2435 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
2447 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
2451 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2454 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2455 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
2456 return range_check (result
, "HYPOT");
2460 /* We use the processor's collating sequence, because all
2461 systems that gfortran currently works on are ASCII. */
2464 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
2470 if (e
->expr_type
!= EXPR_CONSTANT
)
2473 if (e
->value
.character
.length
!= 1)
2475 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
2476 return &gfc_bad_expr
;
2479 index
= e
->value
.character
.string
[0];
2481 if (gfc_option
.warn_surprising
&& index
> 127)
2482 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
2485 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
2487 return &gfc_bad_expr
;
2489 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2491 return range_check (result
, "IACHAR");
2496 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
2498 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2499 gcc_assert (result
->ts
.type
== BT_INTEGER
2500 && result
->expr_type
== EXPR_CONSTANT
);
2502 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2508 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2510 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
2515 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
2517 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2518 gcc_assert (result
->ts
.type
== BT_INTEGER
2519 && result
->expr_type
== EXPR_CONSTANT
);
2521 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2527 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2529 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
2534 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
2538 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2541 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2542 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2544 return range_check (result
, "IAND");
2549 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
2554 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2557 gfc_extract_int (y
, &pos
);
2559 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2561 result
= gfc_copy_expr (x
);
2563 convert_mpz_to_unsigned (result
->value
.integer
,
2564 gfc_integer_kinds
[k
].bit_size
);
2566 mpz_clrbit (result
->value
.integer
, pos
);
2568 gfc_convert_mpz_to_signed (result
->value
.integer
,
2569 gfc_integer_kinds
[k
].bit_size
);
2576 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
2583 if (x
->expr_type
!= EXPR_CONSTANT
2584 || y
->expr_type
!= EXPR_CONSTANT
2585 || z
->expr_type
!= EXPR_CONSTANT
)
2588 gfc_extract_int (y
, &pos
);
2589 gfc_extract_int (z
, &len
);
2591 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
2593 bitsize
= gfc_integer_kinds
[k
].bit_size
;
2595 if (pos
+ len
> bitsize
)
2597 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2598 "bit size at %L", &y
->where
);
2599 return &gfc_bad_expr
;
2602 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2603 convert_mpz_to_unsigned (result
->value
.integer
,
2604 gfc_integer_kinds
[k
].bit_size
);
2606 bits
= XCNEWVEC (int, bitsize
);
2608 for (i
= 0; i
< bitsize
; i
++)
2611 for (i
= 0; i
< len
; i
++)
2612 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
2614 for (i
= 0; i
< bitsize
; i
++)
2617 mpz_clrbit (result
->value
.integer
, i
);
2618 else if (bits
[i
] == 1)
2619 mpz_setbit (result
->value
.integer
, i
);
2621 gfc_internal_error ("IBITS: Bad bit");
2626 gfc_convert_mpz_to_signed (result
->value
.integer
,
2627 gfc_integer_kinds
[k
].bit_size
);
2634 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
2639 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2642 gfc_extract_int (y
, &pos
);
2644 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2646 result
= gfc_copy_expr (x
);
2648 convert_mpz_to_unsigned (result
->value
.integer
,
2649 gfc_integer_kinds
[k
].bit_size
);
2651 mpz_setbit (result
->value
.integer
, pos
);
2653 gfc_convert_mpz_to_signed (result
->value
.integer
,
2654 gfc_integer_kinds
[k
].bit_size
);
2661 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
2667 if (e
->expr_type
!= EXPR_CONSTANT
)
2670 if (e
->value
.character
.length
!= 1)
2672 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
2673 return &gfc_bad_expr
;
2676 index
= e
->value
.character
.string
[0];
2678 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
2680 return &gfc_bad_expr
;
2682 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2684 return range_check (result
, "ICHAR");
2689 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
2693 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2696 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2697 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2699 return range_check (result
, "IEOR");
2704 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
2707 int back
, len
, lensub
;
2708 int i
, j
, k
, count
, index
= 0, start
;
2710 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
2711 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
2714 if (b
!= NULL
&& b
->value
.logical
!= 0)
2719 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
2721 return &gfc_bad_expr
;
2723 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
2725 len
= x
->value
.character
.length
;
2726 lensub
= y
->value
.character
.length
;
2730 mpz_set_si (result
->value
.integer
, 0);
2738 mpz_set_si (result
->value
.integer
, 1);
2741 else if (lensub
== 1)
2743 for (i
= 0; i
< len
; i
++)
2745 for (j
= 0; j
< lensub
; j
++)
2747 if (y
->value
.character
.string
[j
]
2748 == x
->value
.character
.string
[i
])
2758 for (i
= 0; i
< len
; i
++)
2760 for (j
= 0; j
< lensub
; j
++)
2762 if (y
->value
.character
.string
[j
]
2763 == x
->value
.character
.string
[i
])
2768 for (k
= 0; k
< lensub
; k
++)
2770 if (y
->value
.character
.string
[k
]
2771 == x
->value
.character
.string
[k
+ start
])
2775 if (count
== lensub
)
2790 mpz_set_si (result
->value
.integer
, len
+ 1);
2793 else if (lensub
== 1)
2795 for (i
= 0; i
< len
; i
++)
2797 for (j
= 0; j
< lensub
; j
++)
2799 if (y
->value
.character
.string
[j
]
2800 == x
->value
.character
.string
[len
- i
])
2802 index
= len
- i
+ 1;
2810 for (i
= 0; i
< len
; i
++)
2812 for (j
= 0; j
< lensub
; j
++)
2814 if (y
->value
.character
.string
[j
]
2815 == x
->value
.character
.string
[len
- i
])
2818 if (start
<= len
- lensub
)
2821 for (k
= 0; k
< lensub
; k
++)
2822 if (y
->value
.character
.string
[k
]
2823 == x
->value
.character
.string
[k
+ start
])
2826 if (count
== lensub
)
2843 mpz_set_si (result
->value
.integer
, index
);
2844 return range_check (result
, "INDEX");
2849 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
2851 gfc_expr
*result
= NULL
;
2853 if (e
->expr_type
!= EXPR_CONSTANT
)
2856 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
2857 if (result
== &gfc_bad_expr
)
2858 return &gfc_bad_expr
;
2860 return range_check (result
, name
);
2865 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
2869 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
2871 return &gfc_bad_expr
;
2873 return simplify_intconv (e
, kind
, "INT");
2877 gfc_simplify_int2 (gfc_expr
*e
)
2879 return simplify_intconv (e
, 2, "INT2");
2884 gfc_simplify_int8 (gfc_expr
*e
)
2886 return simplify_intconv (e
, 8, "INT8");
2891 gfc_simplify_long (gfc_expr
*e
)
2893 return simplify_intconv (e
, 4, "LONG");
2898 gfc_simplify_ifix (gfc_expr
*e
)
2900 gfc_expr
*rtrunc
, *result
;
2902 if (e
->expr_type
!= EXPR_CONSTANT
)
2905 rtrunc
= gfc_copy_expr (e
);
2906 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
2908 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2910 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
2912 gfc_free_expr (rtrunc
);
2914 return range_check (result
, "IFIX");
2919 gfc_simplify_idint (gfc_expr
*e
)
2921 gfc_expr
*rtrunc
, *result
;
2923 if (e
->expr_type
!= EXPR_CONSTANT
)
2926 rtrunc
= gfc_copy_expr (e
);
2927 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
2929 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2931 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
2933 gfc_free_expr (rtrunc
);
2935 return range_check (result
, "IDINT");
2940 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
2944 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2947 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2948 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2950 return range_check (result
, "IOR");
2955 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
2957 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2958 gcc_assert (result
->ts
.type
== BT_INTEGER
2959 && result
->expr_type
== EXPR_CONSTANT
);
2961 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2967 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2969 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
2974 gfc_simplify_is_iostat_end (gfc_expr
*x
)
2976 if (x
->expr_type
!= EXPR_CONSTANT
)
2979 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
2980 mpz_cmp_si (x
->value
.integer
,
2981 LIBERROR_END
) == 0);
2986 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
2988 if (x
->expr_type
!= EXPR_CONSTANT
)
2991 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
2992 mpz_cmp_si (x
->value
.integer
,
2993 LIBERROR_EOR
) == 0);
2998 gfc_simplify_isnan (gfc_expr
*x
)
3000 if (x
->expr_type
!= EXPR_CONSTANT
)
3003 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3004 mpfr_nan_p (x
->value
.real
));
3008 /* Performs a shift on its first argument. Depending on the last
3009 argument, the shift can be arithmetic, i.e. with filling from the
3010 left like in the SHIFTA intrinsic. */
3012 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3013 bool arithmetic
, int direction
)
3016 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3018 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3021 gfc_extract_int (s
, &shift
);
3023 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3024 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3026 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3030 mpz_set (result
->value
.integer
, e
->value
.integer
);
3034 if (direction
> 0 && shift
< 0)
3036 /* Left shift, as in SHIFTL. */
3037 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3038 return &gfc_bad_expr
;
3040 else if (direction
< 0)
3042 /* Right shift, as in SHIFTR or SHIFTA. */
3045 gfc_error ("Second argument of %s is negative at %L",
3047 return &gfc_bad_expr
;
3053 ashift
= (shift
>= 0 ? shift
: -shift
);
3055 if (ashift
> bitsize
)
3057 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3058 "at %L", name
, &e
->where
);
3059 return &gfc_bad_expr
;
3062 bits
= XCNEWVEC (int, bitsize
);
3064 for (i
= 0; i
< bitsize
; i
++)
3065 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3070 for (i
= 0; i
< shift
; i
++)
3071 mpz_clrbit (result
->value
.integer
, i
);
3073 for (i
= 0; i
< bitsize
- shift
; i
++)
3076 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3078 mpz_setbit (result
->value
.integer
, i
+ shift
);
3084 if (arithmetic
&& bits
[bitsize
- 1])
3085 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3086 mpz_setbit (result
->value
.integer
, i
);
3088 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3089 mpz_clrbit (result
->value
.integer
, i
);
3091 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3094 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3096 mpz_setbit (result
->value
.integer
, i
- ashift
);
3100 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3108 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3110 return simplify_shift (e
, s
, "ISHFT", false, 0);
3115 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3117 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3122 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3124 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3129 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3131 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3136 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3138 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3143 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3145 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3150 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3153 int shift
, ashift
, isize
, ssize
, delta
, k
;
3156 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3159 gfc_extract_int (s
, &shift
);
3161 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3162 isize
= gfc_integer_kinds
[k
].bit_size
;
3166 if (sz
->expr_type
!= EXPR_CONSTANT
)
3169 gfc_extract_int (sz
, &ssize
);
3183 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3184 "BIT_SIZE of first argument at %L", &s
->where
);
3185 return &gfc_bad_expr
;
3188 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3190 mpz_set (result
->value
.integer
, e
->value
.integer
);
3195 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
3197 bits
= XCNEWVEC (int, ssize
);
3199 for (i
= 0; i
< ssize
; i
++)
3200 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3202 delta
= ssize
- ashift
;
3206 for (i
= 0; i
< delta
; i
++)
3209 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3211 mpz_setbit (result
->value
.integer
, i
+ shift
);
3214 for (i
= delta
; i
< ssize
; i
++)
3217 mpz_clrbit (result
->value
.integer
, i
- delta
);
3219 mpz_setbit (result
->value
.integer
, i
- delta
);
3224 for (i
= 0; i
< ashift
; i
++)
3227 mpz_clrbit (result
->value
.integer
, i
+ delta
);
3229 mpz_setbit (result
->value
.integer
, i
+ delta
);
3232 for (i
= ashift
; i
< ssize
; i
++)
3235 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3237 mpz_setbit (result
->value
.integer
, i
+ shift
);
3241 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
3249 gfc_simplify_kind (gfc_expr
*e
)
3251 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
3256 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
3257 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
3259 gfc_expr
*l
, *u
, *result
;
3262 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3263 gfc_default_integer_kind
);
3265 return &gfc_bad_expr
;
3267 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3269 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3270 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3271 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
3275 gfc_expr
* dim
= result
;
3276 mpz_set_si (dim
->value
.integer
, d
);
3278 result
= simplify_size (array
, dim
, k
);
3279 gfc_free_expr (dim
);
3284 mpz_set_si (result
->value
.integer
, 1);
3289 /* Otherwise, we have a variable expression. */
3290 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
3293 if (!gfc_resolve_array_spec (as
, 0))
3296 /* The last dimension of an assumed-size array is special. */
3297 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
3298 || (coarray
&& d
== as
->rank
+ as
->corank
3299 && (!upper
|| gfc_option
.coarray
== GFC_FCOARRAY_SINGLE
)))
3301 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
3303 gfc_free_expr (result
);
3304 return gfc_copy_expr (as
->lower
[d
-1]);
3310 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3312 /* Then, we need to know the extent of the given dimension. */
3313 if (coarray
|| ref
->u
.ar
.type
== AR_FULL
)
3318 if (l
->expr_type
!= EXPR_CONSTANT
|| u
== NULL
3319 || u
->expr_type
!= EXPR_CONSTANT
)
3322 if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
3326 mpz_set_si (result
->value
.integer
, 0);
3328 mpz_set_si (result
->value
.integer
, 1);
3332 /* Nonzero extent. */
3334 mpz_set (result
->value
.integer
, u
->value
.integer
);
3336 mpz_set (result
->value
.integer
, l
->value
.integer
);
3343 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d
- 1, &result
->value
.integer
, NULL
))
3347 mpz_set_si (result
->value
.integer
, (long int) 1);
3351 return range_check (result
, upper
? "UBOUND" : "LBOUND");
3354 gfc_free_expr (result
);
3360 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3366 if (array
->ts
.type
== BT_CLASS
)
3369 if (array
->expr_type
!= EXPR_VARIABLE
)
3376 /* Follow any component references. */
3377 as
= array
->symtree
->n
.sym
->as
;
3378 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3383 switch (ref
->u
.ar
.type
)
3390 /* We're done because 'as' has already been set in the
3391 previous iteration. */
3408 as
= ref
->u
.c
.component
->as
;
3420 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_SHAPE
3421 || as
->type
== AS_ASSUMED_RANK
))
3426 /* Multi-dimensional bounds. */
3427 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3431 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
3432 if (upper
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
3434 /* An error message will be emitted in
3435 check_assumed_size_reference (resolve.c). */
3436 return &gfc_bad_expr
;
3439 /* Simplify the bounds for each dimension. */
3440 for (d
= 0; d
< array
->rank
; d
++)
3442 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
3444 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3448 for (j
= 0; j
< d
; j
++)
3449 gfc_free_expr (bounds
[j
]);
3454 /* Allocate the result expression. */
3455 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3456 gfc_default_integer_kind
);
3458 return &gfc_bad_expr
;
3460 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
3462 /* The result is a rank 1 array; its size is the rank of the first
3463 argument to {L,U}BOUND. */
3465 e
->shape
= gfc_get_shape (1);
3466 mpz_init_set_ui (e
->shape
[0], array
->rank
);
3468 /* Create the constructor for this array. */
3469 for (d
= 0; d
< array
->rank
; d
++)
3470 gfc_constructor_append_expr (&e
->value
.constructor
,
3471 bounds
[d
], &e
->where
);
3477 /* A DIM argument is specified. */
3478 if (dim
->expr_type
!= EXPR_CONSTANT
)
3481 d
= mpz_get_si (dim
->value
.integer
);
3483 if ((d
< 1 || d
> array
->rank
)
3484 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
3486 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3487 return &gfc_bad_expr
;
3490 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3493 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
3499 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3505 if (array
->expr_type
!= EXPR_VARIABLE
)
3508 /* Follow any component references. */
3509 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
3510 ? array
->ts
.u
.derived
->components
->as
3511 : array
->symtree
->n
.sym
->as
;
3512 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3517 switch (ref
->u
.ar
.type
)
3520 if (ref
->u
.ar
.as
->corank
> 0)
3522 gcc_assert (as
== ref
->u
.ar
.as
);
3529 /* We're done because 'as' has already been set in the
3530 previous iteration. */
3547 as
= ref
->u
.c
.component
->as
;
3560 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
3565 /* Multi-dimensional cobounds. */
3566 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3570 /* Simplify the cobounds for each dimension. */
3571 for (d
= 0; d
< as
->corank
; d
++)
3573 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
3574 upper
, as
, ref
, true);
3575 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3579 for (j
= 0; j
< d
; j
++)
3580 gfc_free_expr (bounds
[j
]);
3585 /* Allocate the result expression. */
3586 e
= gfc_get_expr ();
3587 e
->where
= array
->where
;
3588 e
->expr_type
= EXPR_ARRAY
;
3589 e
->ts
.type
= BT_INTEGER
;
3590 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
3591 gfc_default_integer_kind
);
3595 return &gfc_bad_expr
;
3599 /* The result is a rank 1 array; its size is the rank of the first
3600 argument to {L,U}COBOUND. */
3602 e
->shape
= gfc_get_shape (1);
3603 mpz_init_set_ui (e
->shape
[0], as
->corank
);
3605 /* Create the constructor for this array. */
3606 for (d
= 0; d
< as
->corank
; d
++)
3607 gfc_constructor_append_expr (&e
->value
.constructor
,
3608 bounds
[d
], &e
->where
);
3613 /* A DIM argument is specified. */
3614 if (dim
->expr_type
!= EXPR_CONSTANT
)
3617 d
= mpz_get_si (dim
->value
.integer
);
3619 if (d
< 1 || d
> as
->corank
)
3621 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3622 return &gfc_bad_expr
;
3625 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
3631 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3633 return simplify_bound (array
, dim
, kind
, 0);
3638 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3640 return simplify_cobound (array
, dim
, kind
, 0);
3644 gfc_simplify_leadz (gfc_expr
*e
)
3646 unsigned long lz
, bs
;
3649 if (e
->expr_type
!= EXPR_CONSTANT
)
3652 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3653 bs
= gfc_integer_kinds
[i
].bit_size
;
3654 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
3656 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
3659 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
3661 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
3666 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
3669 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
3672 return &gfc_bad_expr
;
3674 if (e
->expr_type
== EXPR_CONSTANT
)
3676 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3677 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
3678 return range_check (result
, "LEN");
3680 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
3681 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3682 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
3684 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3685 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
3686 return range_check (result
, "LEN");
3694 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
3698 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
3701 return &gfc_bad_expr
;
3703 if (e
->expr_type
!= EXPR_CONSTANT
)
3706 len
= e
->value
.character
.length
;
3707 for (count
= 0, i
= 1; i
<= len
; i
++)
3708 if (e
->value
.character
.string
[len
- i
] == ' ')
3713 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
3714 return range_check (result
, "LEN_TRIM");
3718 gfc_simplify_lgamma (gfc_expr
*x
)
3723 if (x
->expr_type
!= EXPR_CONSTANT
)
3726 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3727 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
3729 return range_check (result
, "LGAMMA");
3734 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
3736 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3739 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3740 gfc_compare_string (a
, b
) >= 0);
3745 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
3747 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3750 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3751 gfc_compare_string (a
, b
) > 0);
3756 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
3758 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3761 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3762 gfc_compare_string (a
, b
) <= 0);
3767 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
3769 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3772 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3773 gfc_compare_string (a
, b
) < 0);
3778 gfc_simplify_log (gfc_expr
*x
)
3782 if (x
->expr_type
!= EXPR_CONSTANT
)
3785 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3790 if (mpfr_sgn (x
->value
.real
) <= 0)
3792 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3793 "to zero", &x
->where
);
3794 gfc_free_expr (result
);
3795 return &gfc_bad_expr
;
3798 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3802 if ((mpfr_sgn (mpc_realref (x
->value
.complex)) == 0)
3803 && (mpfr_sgn (mpc_imagref (x
->value
.complex)) == 0))
3805 gfc_error ("Complex argument of LOG at %L cannot be zero",
3807 gfc_free_expr (result
);
3808 return &gfc_bad_expr
;
3811 gfc_set_model_kind (x
->ts
.kind
);
3812 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
3816 gfc_internal_error ("gfc_simplify_log: bad type");
3819 return range_check (result
, "LOG");
3824 gfc_simplify_log10 (gfc_expr
*x
)
3828 if (x
->expr_type
!= EXPR_CONSTANT
)
3831 if (mpfr_sgn (x
->value
.real
) <= 0)
3833 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3834 "to zero", &x
->where
);
3835 return &gfc_bad_expr
;
3838 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3839 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3841 return range_check (result
, "LOG10");
3846 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
3850 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
3852 return &gfc_bad_expr
;
3854 if (e
->expr_type
!= EXPR_CONSTANT
)
3857 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
3862 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3865 int row
, result_rows
, col
, result_columns
;
3866 int stride_a
, offset_a
, stride_b
, offset_b
;
3868 if (!is_constant_array_expr (matrix_a
)
3869 || !is_constant_array_expr (matrix_b
))
3872 gcc_assert (gfc_compare_types (&matrix_a
->ts
, &matrix_b
->ts
));
3873 result
= gfc_get_array_expr (matrix_a
->ts
.type
,
3877 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
3880 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
3882 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
3885 result
->shape
= gfc_get_shape (result
->rank
);
3886 mpz_init_set_si (result
->shape
[0], result_columns
);
3888 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
3890 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
3892 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
3896 result
->shape
= gfc_get_shape (result
->rank
);
3897 mpz_init_set_si (result
->shape
[0], result_rows
);
3899 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
3901 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
3902 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
3903 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
3904 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
3907 result
->shape
= gfc_get_shape (result
->rank
);
3908 mpz_init_set_si (result
->shape
[0], result_rows
);
3909 mpz_init_set_si (result
->shape
[1], result_columns
);
3914 offset_a
= offset_b
= 0;
3915 for (col
= 0; col
< result_columns
; ++col
)
3919 for (row
= 0; row
< result_rows
; ++row
)
3921 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
3922 matrix_b
, 1, offset_b
, false);
3923 gfc_constructor_append_expr (&result
->value
.constructor
,
3929 offset_b
+= stride_b
;
3937 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
3943 if (i
->expr_type
!= EXPR_CONSTANT
)
3946 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
3948 return &gfc_bad_expr
;
3949 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3951 s
= gfc_extract_int (i
, &arg
);
3954 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
3956 /* MASKR(n) = 2^n - 1 */
3957 mpz_set_ui (result
->value
.integer
, 1);
3958 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
3959 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
3961 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
3968 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
3975 if (i
->expr_type
!= EXPR_CONSTANT
)
3978 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
3980 return &gfc_bad_expr
;
3981 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3983 s
= gfc_extract_int (i
, &arg
);
3986 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
3988 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
3989 mpz_init_set_ui (z
, 1);
3990 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
3991 mpz_set_ui (result
->value
.integer
, 1);
3992 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
3993 gfc_integer_kinds
[k
].bit_size
- arg
);
3994 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
3997 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4004 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4007 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4009 if (mask
->expr_type
== EXPR_CONSTANT
)
4010 return gfc_get_parentheses (gfc_copy_expr (mask
->value
.logical
4011 ? tsource
: fsource
));
4013 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4014 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4017 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4019 if (tsource
->ts
.type
== BT_DERIVED
)
4020 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4021 else if (tsource
->ts
.type
== BT_CHARACTER
)
4022 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4024 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4025 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4026 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4030 if (mask_ctor
->expr
->value
.logical
)
4031 gfc_constructor_append_expr (&result
->value
.constructor
,
4032 gfc_copy_expr (tsource_ctor
->expr
),
4035 gfc_constructor_append_expr (&result
->value
.constructor
,
4036 gfc_copy_expr (fsource_ctor
->expr
),
4038 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4039 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4040 mask_ctor
= gfc_constructor_next (mask_ctor
);
4043 result
->shape
= gfc_get_shape (1);
4044 gfc_array_size (result
, &result
->shape
[0]);
4051 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4053 mpz_t arg1
, arg2
, mask
;
4056 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4057 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4060 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4062 /* Convert all argument to unsigned. */
4063 mpz_init_set (arg1
, i
->value
.integer
);
4064 mpz_init_set (arg2
, j
->value
.integer
);
4065 mpz_init_set (mask
, mask_expr
->value
.integer
);
4067 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4068 mpz_and (arg1
, arg1
, mask
);
4069 mpz_com (mask
, mask
);
4070 mpz_and (arg2
, arg2
, mask
);
4071 mpz_ior (result
->value
.integer
, arg1
, arg2
);
4081 /* Selects between current value and extremum for simplify_min_max
4082 and simplify_minval_maxval. */
4084 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
)
4086 switch (arg
->ts
.type
)
4089 if (mpz_cmp (arg
->value
.integer
,
4090 extremum
->value
.integer
) * sign
> 0)
4091 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
4095 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4097 mpfr_max (extremum
->value
.real
, extremum
->value
.real
,
4098 arg
->value
.real
, GFC_RND_MODE
);
4100 mpfr_min (extremum
->value
.real
, extremum
->value
.real
,
4101 arg
->value
.real
, GFC_RND_MODE
);
4105 #define LENGTH(x) ((x)->value.character.length)
4106 #define STRING(x) ((x)->value.character.string)
4107 if (LENGTH (extremum
) < LENGTH(arg
))
4109 gfc_char_t
*tmp
= STRING(extremum
);
4111 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
4112 memcpy (STRING(extremum
), tmp
,
4113 LENGTH(extremum
) * sizeof (gfc_char_t
));
4114 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
4115 LENGTH(arg
) - LENGTH(extremum
));
4116 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
4117 LENGTH(extremum
) = LENGTH(arg
);
4121 if (gfc_compare_string (arg
, extremum
) * sign
> 0)
4123 free (STRING(extremum
));
4124 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
4125 memcpy (STRING(extremum
), STRING(arg
),
4126 LENGTH(arg
) * sizeof (gfc_char_t
));
4127 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
4128 LENGTH(extremum
) - LENGTH(arg
));
4129 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
4136 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4141 /* This function is special since MAX() can take any number of
4142 arguments. The simplified expression is a rewritten version of the
4143 argument list containing at most one constant element. Other
4144 constant elements are deleted. Because the argument list has
4145 already been checked, this function always succeeds. sign is 1 for
4146 MAX(), -1 for MIN(). */
4149 simplify_min_max (gfc_expr
*expr
, int sign
)
4151 gfc_actual_arglist
*arg
, *last
, *extremum
;
4152 gfc_intrinsic_sym
* specific
;
4156 specific
= expr
->value
.function
.isym
;
4158 arg
= expr
->value
.function
.actual
;
4160 for (; arg
; last
= arg
, arg
= arg
->next
)
4162 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
4165 if (extremum
== NULL
)
4171 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
4173 /* Delete the extra constant argument. */
4174 last
->next
= arg
->next
;
4177 gfc_free_actual_arglist (arg
);
4181 /* If there is one value left, replace the function call with the
4183 if (expr
->value
.function
.actual
->next
!= NULL
)
4186 /* Convert to the correct type and kind. */
4187 if (expr
->ts
.type
!= BT_UNKNOWN
)
4188 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4189 expr
->ts
.type
, expr
->ts
.kind
);
4191 if (specific
->ts
.type
!= BT_UNKNOWN
)
4192 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4193 specific
->ts
.type
, specific
->ts
.kind
);
4195 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
4200 gfc_simplify_min (gfc_expr
*e
)
4202 return simplify_min_max (e
, -1);
4207 gfc_simplify_max (gfc_expr
*e
)
4209 return simplify_min_max (e
, 1);
4213 /* This is a simplified version of simplify_min_max to provide
4214 simplification of minval and maxval for a vector. */
4217 simplify_minval_maxval (gfc_expr
*expr
, int sign
)
4219 gfc_constructor
*c
, *extremum
;
4220 gfc_intrinsic_sym
* specific
;
4223 specific
= expr
->value
.function
.isym
;
4225 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4226 c
; c
= gfc_constructor_next (c
))
4228 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4231 if (extremum
== NULL
)
4237 min_max_choose (c
->expr
, extremum
->expr
, sign
);
4240 if (extremum
== NULL
)
4243 /* Convert to the correct type and kind. */
4244 if (expr
->ts
.type
!= BT_UNKNOWN
)
4245 return gfc_convert_constant (extremum
->expr
,
4246 expr
->ts
.type
, expr
->ts
.kind
);
4248 if (specific
->ts
.type
!= BT_UNKNOWN
)
4249 return gfc_convert_constant (extremum
->expr
,
4250 specific
->ts
.type
, specific
->ts
.kind
);
4252 return gfc_copy_expr (extremum
->expr
);
4257 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4259 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4262 return simplify_minval_maxval (array
, -1);
4267 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4269 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4272 return simplify_minval_maxval (array
, 1);
4277 gfc_simplify_maxexponent (gfc_expr
*x
)
4279 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4280 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4281 gfc_real_kinds
[i
].max_exponent
);
4286 gfc_simplify_minexponent (gfc_expr
*x
)
4288 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4289 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4290 gfc_real_kinds
[i
].min_exponent
);
4295 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
4300 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4303 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4304 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4309 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4311 /* Result is processor-dependent. */
4312 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
4313 gfc_free_expr (result
);
4314 return &gfc_bad_expr
;
4316 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4320 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4322 /* Result is processor-dependent. */
4323 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
4324 gfc_free_expr (result
);
4325 return &gfc_bad_expr
;
4328 gfc_set_model_kind (kind
);
4329 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4334 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4337 return range_check (result
, "MOD");
4342 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
4347 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4350 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4351 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4356 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4358 /* Result is processor-dependent. This processor just opts
4359 to not handle it at all. */
4360 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
4361 gfc_free_expr (result
);
4362 return &gfc_bad_expr
;
4364 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4369 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4371 /* Result is processor-dependent. */
4372 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
4373 gfc_free_expr (result
);
4374 return &gfc_bad_expr
;
4377 gfc_set_model_kind (kind
);
4378 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4380 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
4382 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
4383 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
4387 mpfr_copysign (result
->value
.real
, result
->value
.real
,
4388 p
->value
.real
, GFC_RND_MODE
);
4392 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4395 return range_check (result
, "MODULO");
4399 /* Exists for the sole purpose of consistency with other intrinsics. */
4401 gfc_simplify_mvbits (gfc_expr
*f ATTRIBUTE_UNUSED
,
4402 gfc_expr
*fp ATTRIBUTE_UNUSED
,
4403 gfc_expr
*l ATTRIBUTE_UNUSED
,
4404 gfc_expr
*to ATTRIBUTE_UNUSED
,
4405 gfc_expr
*tp ATTRIBUTE_UNUSED
)
4412 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
4415 mp_exp_t emin
, emax
;
4418 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
4421 result
= gfc_copy_expr (x
);
4423 /* Save current values of emin and emax. */
4424 emin
= mpfr_get_emin ();
4425 emax
= mpfr_get_emax ();
4427 /* Set emin and emax for the current model number. */
4428 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
4429 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
4430 mpfr_get_prec(result
->value
.real
) + 1);
4431 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
4432 mpfr_check_range (result
->value
.real
, 0, GMP_RNDU
);
4434 if (mpfr_sgn (s
->value
.real
) > 0)
4436 mpfr_nextabove (result
->value
.real
);
4437 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
4441 mpfr_nextbelow (result
->value
.real
);
4442 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
4445 mpfr_set_emin (emin
);
4446 mpfr_set_emax (emax
);
4448 /* Only NaN can occur. Do not use range check as it gives an
4449 error for denormal numbers. */
4450 if (mpfr_nan_p (result
->value
.real
) && gfc_option
.flag_range_check
)
4452 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
4453 gfc_free_expr (result
);
4454 return &gfc_bad_expr
;
4462 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
4464 gfc_expr
*itrunc
, *result
;
4467 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
4469 return &gfc_bad_expr
;
4471 if (e
->expr_type
!= EXPR_CONSTANT
)
4474 itrunc
= gfc_copy_expr (e
);
4475 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
4477 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
4478 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
4480 gfc_free_expr (itrunc
);
4482 return range_check (result
, name
);
4487 gfc_simplify_new_line (gfc_expr
*e
)
4491 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
4492 result
->value
.character
.string
[0] = '\n';
4499 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
4501 return simplify_nint ("NINT", e
, k
);
4506 gfc_simplify_idnint (gfc_expr
*e
)
4508 return simplify_nint ("IDNINT", e
, NULL
);
4513 add_squared (gfc_expr
*result
, gfc_expr
*e
)
4517 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4518 gcc_assert (result
->ts
.type
== BT_REAL
4519 && result
->expr_type
== EXPR_CONSTANT
);
4521 gfc_set_model_kind (result
->ts
.kind
);
4523 mpfr_pow_ui (tmp
, e
->value
.real
, 2, GFC_RND_MODE
);
4524 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
4533 do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
4535 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4536 gcc_assert (result
->ts
.type
== BT_REAL
4537 && result
->expr_type
== EXPR_CONSTANT
);
4539 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
4540 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4546 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
4550 if (!is_constant_array_expr (e
)
4551 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
4554 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4555 init_result_expr (result
, 0, NULL
);
4557 if (!dim
|| e
->rank
== 1)
4559 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
4561 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4564 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
4565 add_squared
, &do_sqrt
);
4572 gfc_simplify_not (gfc_expr
*e
)
4576 if (e
->expr_type
!= EXPR_CONSTANT
)
4579 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4580 mpz_com (result
->value
.integer
, e
->value
.integer
);
4582 return range_check (result
, "NOT");
4587 gfc_simplify_null (gfc_expr
*mold
)
4593 result
= gfc_copy_expr (mold
);
4594 result
->expr_type
= EXPR_NULL
;
4597 result
= gfc_get_null_expr (NULL
);
4604 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
4608 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
4610 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4611 return &gfc_bad_expr
;
4614 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
4617 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
4620 /* FIXME: gfc_current_locus is wrong. */
4621 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
4622 &gfc_current_locus
);
4624 if (failed
&& failed
->value
.logical
!= 0)
4625 mpz_set_si (result
->value
.integer
, 0);
4627 mpz_set_si (result
->value
.integer
, 1);
4634 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
4639 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4642 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4647 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
4648 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4649 return range_check (result
, "OR");
4652 return gfc_get_logical_expr (kind
, &x
->where
,
4653 x
->value
.logical
|| y
->value
.logical
);
4661 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4664 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
4666 if (!is_constant_array_expr (array
)
4667 || !is_constant_array_expr (vector
)
4668 || (!gfc_is_constant_expr (mask
)
4669 && !is_constant_array_expr (mask
)))
4672 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
4673 if (array
->ts
.type
== BT_DERIVED
)
4674 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
4676 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
4677 vector_ctor
= vector
4678 ? gfc_constructor_first (vector
->value
.constructor
)
4681 if (mask
->expr_type
== EXPR_CONSTANT
4682 && mask
->value
.logical
)
4684 /* Copy all elements of ARRAY to RESULT. */
4687 gfc_constructor_append_expr (&result
->value
.constructor
,
4688 gfc_copy_expr (array_ctor
->expr
),
4691 array_ctor
= gfc_constructor_next (array_ctor
);
4692 vector_ctor
= gfc_constructor_next (vector_ctor
);
4695 else if (mask
->expr_type
== EXPR_ARRAY
)
4697 /* Copy only those elements of ARRAY to RESULT whose
4698 MASK equals .TRUE.. */
4699 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4702 if (mask_ctor
->expr
->value
.logical
)
4704 gfc_constructor_append_expr (&result
->value
.constructor
,
4705 gfc_copy_expr (array_ctor
->expr
),
4707 vector_ctor
= gfc_constructor_next (vector_ctor
);
4710 array_ctor
= gfc_constructor_next (array_ctor
);
4711 mask_ctor
= gfc_constructor_next (mask_ctor
);
4715 /* Append any left-over elements from VECTOR to RESULT. */
4718 gfc_constructor_append_expr (&result
->value
.constructor
,
4719 gfc_copy_expr (vector_ctor
->expr
),
4721 vector_ctor
= gfc_constructor_next (vector_ctor
);
4724 result
->shape
= gfc_get_shape (1);
4725 gfc_array_size (result
, &result
->shape
[0]);
4727 if (array
->ts
.type
== BT_CHARACTER
)
4728 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
4735 do_xor (gfc_expr
*result
, gfc_expr
*e
)
4737 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
4738 gcc_assert (result
->ts
.type
== BT_LOGICAL
4739 && result
->expr_type
== EXPR_CONSTANT
);
4741 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
4748 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
4750 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
4755 gfc_simplify_popcnt (gfc_expr
*e
)
4760 if (e
->expr_type
!= EXPR_CONSTANT
)
4763 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4765 /* Convert argument to unsigned, then count the '1' bits. */
4766 mpz_init_set (x
, e
->value
.integer
);
4767 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
4768 res
= mpz_popcount (x
);
4771 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
4776 gfc_simplify_poppar (gfc_expr
*e
)
4782 if (e
->expr_type
!= EXPR_CONSTANT
)
4785 popcnt
= gfc_simplify_popcnt (e
);
4786 gcc_assert (popcnt
);
4788 s
= gfc_extract_int (popcnt
, &i
);
4791 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
4796 gfc_simplify_precision (gfc_expr
*e
)
4798 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4799 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
4800 gfc_real_kinds
[i
].precision
);
4805 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
4807 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
4812 gfc_simplify_radix (gfc_expr
*e
)
4815 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4820 i
= gfc_integer_kinds
[i
].radix
;
4824 i
= gfc_real_kinds
[i
].radix
;
4831 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4836 gfc_simplify_range (gfc_expr
*e
)
4839 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4844 i
= gfc_integer_kinds
[i
].range
;
4849 i
= gfc_real_kinds
[i
].range
;
4856 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4861 gfc_simplify_rank (gfc_expr
*e
)
4867 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
4872 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
4874 gfc_expr
*result
= NULL
;
4877 if (e
->ts
.type
== BT_COMPLEX
)
4878 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
4880 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
4883 return &gfc_bad_expr
;
4885 if (e
->expr_type
!= EXPR_CONSTANT
)
4888 if (convert_boz (e
, kind
) == &gfc_bad_expr
)
4889 return &gfc_bad_expr
;
4891 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
4892 if (result
== &gfc_bad_expr
)
4893 return &gfc_bad_expr
;
4895 return range_check (result
, "REAL");
4900 gfc_simplify_realpart (gfc_expr
*e
)
4904 if (e
->expr_type
!= EXPR_CONSTANT
)
4907 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
4908 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
4910 return range_check (result
, "REALPART");
4914 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
4917 int i
, j
, len
, ncop
, nlen
;
4919 bool have_length
= false;
4921 /* If NCOPIES isn't a constant, there's nothing we can do. */
4922 if (n
->expr_type
!= EXPR_CONSTANT
)
4925 /* If NCOPIES is negative, it's an error. */
4926 if (mpz_sgn (n
->value
.integer
) < 0)
4928 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4930 return &gfc_bad_expr
;
4933 /* If we don't know the character length, we can do no more. */
4934 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
4935 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4937 len
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
4940 else if (e
->expr_type
== EXPR_CONSTANT
4941 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
4943 len
= e
->value
.character
.length
;
4948 /* If the source length is 0, any value of NCOPIES is valid
4949 and everything behaves as if NCOPIES == 0. */
4952 mpz_set_ui (ncopies
, 0);
4954 mpz_set (ncopies
, n
->value
.integer
);
4956 /* Check that NCOPIES isn't too large. */
4962 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
4964 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4968 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
4969 e
->ts
.u
.cl
->length
->value
.integer
);
4973 mpz_init_set_si (mlen
, len
);
4974 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
4978 /* The check itself. */
4979 if (mpz_cmp (ncopies
, max
) > 0)
4982 mpz_clear (ncopies
);
4983 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4985 return &gfc_bad_expr
;
4990 mpz_clear (ncopies
);
4992 /* For further simplification, we need the character string to be
4994 if (e
->expr_type
!= EXPR_CONSTANT
)
4998 (e
->ts
.u
.cl
->length
&&
4999 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
)) != 0)
5001 const char *res
= gfc_extract_int (n
, &ncop
);
5002 gcc_assert (res
== NULL
);
5008 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
5010 len
= e
->value
.character
.length
;
5013 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
5014 for (i
= 0; i
< ncop
; i
++)
5015 for (j
= 0; j
< len
; j
++)
5016 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
5018 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
5023 /* This one is a bear, but mainly has to do with shuffling elements. */
5026 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
5027 gfc_expr
*pad
, gfc_expr
*order_exp
)
5029 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
5030 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
5034 gfc_expr
*e
, *result
;
5036 /* Check that argument expression types are OK. */
5037 if (!is_constant_array_expr (source
)
5038 || !is_constant_array_expr (shape_exp
)
5039 || !is_constant_array_expr (pad
)
5040 || !is_constant_array_expr (order_exp
))
5043 /* Proceed with simplification, unpacking the array. */
5050 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
5054 gfc_extract_int (e
, &shape
[rank
]);
5056 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
5057 gcc_assert (shape
[rank
] >= 0);
5062 gcc_assert (rank
> 0);
5064 /* Now unpack the order array if present. */
5065 if (order_exp
== NULL
)
5067 for (i
= 0; i
< rank
; i
++)
5072 for (i
= 0; i
< rank
; i
++)
5075 for (i
= 0; i
< rank
; i
++)
5077 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
5080 gfc_extract_int (e
, &order
[i
]);
5082 gcc_assert (order
[i
] >= 1 && order
[i
] <= rank
);
5084 gcc_assert (x
[order
[i
]] == 0);
5089 /* Count the elements in the source and padding arrays. */
5094 gfc_array_size (pad
, &size
);
5095 npad
= mpz_get_ui (size
);
5099 gfc_array_size (source
, &size
);
5100 nsource
= mpz_get_ui (size
);
5103 /* If it weren't for that pesky permutation we could just loop
5104 through the source and round out any shortage with pad elements.
5105 But no, someone just had to have the compiler do something the
5106 user should be doing. */
5108 for (i
= 0; i
< rank
; i
++)
5111 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
5113 if (source
->ts
.type
== BT_DERIVED
)
5114 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
5115 result
->rank
= rank
;
5116 result
->shape
= gfc_get_shape (rank
);
5117 for (i
= 0; i
< rank
; i
++)
5118 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
5120 while (nsource
> 0 || npad
> 0)
5122 /* Figure out which element to extract. */
5123 mpz_set_ui (index
, 0);
5125 for (i
= rank
- 1; i
>= 0; i
--)
5127 mpz_add_ui (index
, index
, x
[order
[i
]]);
5129 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
5132 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
5133 gfc_internal_error ("Reshaped array too large at %C");
5135 j
= mpz_get_ui (index
);
5138 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
5141 gcc_assert (npad
> 0);
5145 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
5149 gfc_constructor_append_expr (&result
->value
.constructor
,
5150 gfc_copy_expr (e
), &e
->where
);
5152 /* Calculate the next element. */
5156 if (++x
[i
] < shape
[i
])
5172 gfc_simplify_rrspacing (gfc_expr
*x
)
5178 if (x
->expr_type
!= EXPR_CONSTANT
)
5181 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5183 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5184 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5186 /* Special case x = -0 and 0. */
5187 if (mpfr_sgn (result
->value
.real
) == 0)
5189 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5193 /* | x * 2**(-e) | * 2**p. */
5194 e
= - (long int) mpfr_get_exp (x
->value
.real
);
5195 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
5197 p
= (long int) gfc_real_kinds
[i
].digits
;
5198 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
5200 return range_check (result
, "RRSPACING");
5205 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
5207 int k
, neg_flag
, power
, exp_range
;
5208 mpfr_t scale
, radix
;
5211 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5214 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5216 if (mpfr_sgn (x
->value
.real
) == 0)
5218 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5222 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5224 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
5226 /* This check filters out values of i that would overflow an int. */
5227 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
5228 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
5230 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
5231 gfc_free_expr (result
);
5232 return &gfc_bad_expr
;
5235 /* Compute scale = radix ** power. */
5236 power
= mpz_get_si (i
->value
.integer
);
5246 gfc_set_model_kind (x
->ts
.kind
);
5249 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
5250 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
5253 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5255 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5257 mpfr_clears (scale
, radix
, NULL
);
5259 return range_check (result
, "SCALE");
5263 /* Variants of strspn and strcspn that operate on wide characters. */
5266 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5269 const gfc_char_t
*c
;
5273 for (c
= s2
; *c
; c
++)
5287 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5290 const gfc_char_t
*c
;
5294 for (c
= s2
; *c
; c
++)
5309 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
5314 size_t indx
, len
, lenc
;
5315 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
5318 return &gfc_bad_expr
;
5320 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
5321 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
5324 if (b
!= NULL
&& b
->value
.logical
!= 0)
5329 len
= e
->value
.character
.length
;
5330 lenc
= c
->value
.character
.length
;
5332 if (len
== 0 || lenc
== 0)
5340 indx
= wide_strcspn (e
->value
.character
.string
,
5341 c
->value
.character
.string
) + 1;
5348 for (indx
= len
; indx
> 0; indx
--)
5350 for (i
= 0; i
< lenc
; i
++)
5352 if (c
->value
.character
.string
[i
]
5353 == e
->value
.character
.string
[indx
- 1])
5362 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
5363 return range_check (result
, "SCAN");
5368 gfc_simplify_selected_char_kind (gfc_expr
*e
)
5372 if (e
->expr_type
!= EXPR_CONSTANT
)
5375 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
5376 || gfc_compare_with_Cstring (e
, "default", false) == 0)
5378 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
5383 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5388 gfc_simplify_selected_int_kind (gfc_expr
*e
)
5392 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
5397 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
5398 if (gfc_integer_kinds
[i
].range
>= range
5399 && gfc_integer_kinds
[i
].kind
< kind
)
5400 kind
= gfc_integer_kinds
[i
].kind
;
5402 if (kind
== INT_MAX
)
5405 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5410 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
5412 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
5414 locus
*loc
= &gfc_current_locus
;
5420 if (p
->expr_type
!= EXPR_CONSTANT
5421 || gfc_extract_int (p
, &precision
) != NULL
)
5430 if (q
->expr_type
!= EXPR_CONSTANT
5431 || gfc_extract_int (q
, &range
) != NULL
)
5442 if (rdx
->expr_type
!= EXPR_CONSTANT
5443 || gfc_extract_int (rdx
, &radix
) != NULL
)
5451 found_precision
= 0;
5455 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5457 if (gfc_real_kinds
[i
].precision
>= precision
)
5458 found_precision
= 1;
5460 if (gfc_real_kinds
[i
].range
>= range
)
5463 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5466 if (gfc_real_kinds
[i
].precision
>= precision
5467 && gfc_real_kinds
[i
].range
>= range
5468 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5469 && gfc_real_kinds
[i
].kind
< kind
)
5470 kind
= gfc_real_kinds
[i
].kind
;
5473 if (kind
== INT_MAX
)
5475 if (found_radix
&& found_range
&& !found_precision
)
5477 else if (found_radix
&& found_precision
&& !found_range
)
5479 else if (found_radix
&& !found_precision
&& !found_range
)
5481 else if (found_radix
)
5487 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
5492 gfc_simplify_ieee_selected_real_kind (gfc_expr
*expr
)
5494 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
5495 gfc_expr
*p
= arg
->expr
, *r
= arg
->next
->expr
,
5496 *rad
= arg
->next
->next
->expr
;
5497 int precision
, range
, radix
, res
;
5498 int found_precision
, found_range
, found_radix
, i
;
5502 if (p
->expr_type
!= EXPR_CONSTANT
5503 || gfc_extract_int (p
, &precision
) != NULL
)
5511 if (r
->expr_type
!= EXPR_CONSTANT
5512 || gfc_extract_int (r
, &range
) != NULL
)
5520 if (rad
->expr_type
!= EXPR_CONSTANT
5521 || gfc_extract_int (rad
, &radix
) != NULL
)
5528 found_precision
= 0;
5532 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5534 /* We only support the target's float and double types. */
5535 if (!gfc_real_kinds
[i
].c_float
&& !gfc_real_kinds
[i
].c_double
)
5538 if (gfc_real_kinds
[i
].precision
>= precision
)
5539 found_precision
= 1;
5541 if (gfc_real_kinds
[i
].range
>= range
)
5544 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5547 if (gfc_real_kinds
[i
].precision
>= precision
5548 && gfc_real_kinds
[i
].range
>= range
5549 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5550 && gfc_real_kinds
[i
].kind
< res
)
5551 res
= gfc_real_kinds
[i
].kind
;
5556 if (found_radix
&& found_range
&& !found_precision
)
5558 else if (found_radix
&& found_precision
&& !found_range
)
5560 else if (found_radix
&& !found_precision
&& !found_range
)
5562 else if (found_radix
)
5568 return gfc_get_int_expr (gfc_default_integer_kind
, &expr
->where
, res
);
5573 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5576 mpfr_t exp
, absv
, log2
, pow2
, frac
;
5579 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5582 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5584 if (mpfr_sgn (x
->value
.real
) == 0)
5586 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5590 gfc_set_model_kind (x
->ts
.kind
);
5597 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
5598 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
5600 mpfr_trunc (log2
, log2
);
5601 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
5603 /* Old exponent value, and fraction. */
5604 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
5606 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
5609 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
5610 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
5612 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
5614 return range_check (result
, "SET_EXPONENT");
5619 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
5621 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5622 gfc_expr
*result
, *e
, *f
;
5626 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
5628 if (source
->rank
== -1)
5631 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
5633 if (source
->rank
== 0)
5636 if (source
->expr_type
== EXPR_VARIABLE
)
5638 ar
= gfc_find_array_ref (source
);
5639 t
= gfc_array_ref_shape (ar
, shape
);
5641 else if (source
->shape
)
5644 for (n
= 0; n
< source
->rank
; n
++)
5646 mpz_init (shape
[n
]);
5647 mpz_set (shape
[n
], source
->shape
[n
]);
5653 for (n
= 0; n
< source
->rank
; n
++)
5655 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
5658 mpz_set (e
->value
.integer
, shape
[n
]);
5661 mpz_set_ui (e
->value
.integer
, n
+ 1);
5663 f
= simplify_size (source
, e
, k
);
5667 gfc_free_expr (result
);
5674 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
5676 gfc_free_expr (result
);
5678 gfc_clear_shape (shape
, source
->rank
);
5679 return &gfc_bad_expr
;
5682 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
5686 gfc_clear_shape (shape
, source
->rank
);
5693 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
5696 gfc_expr
*return_value
;
5699 /* For unary operations, the size of the result is given by the size
5700 of the operand. For binary ones, it's the size of the first operand
5701 unless it is scalar, then it is the size of the second. */
5702 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
5704 gfc_expr
* replacement
;
5705 gfc_expr
* simplified
;
5707 switch (array
->value
.op
.op
)
5709 /* Unary operations. */
5711 case INTRINSIC_UPLUS
:
5712 case INTRINSIC_UMINUS
:
5713 case INTRINSIC_PARENTHESES
:
5714 replacement
= array
->value
.op
.op1
;
5717 /* Binary operations. If any one of the operands is scalar, take
5718 the other one's size. If both of them are arrays, it does not
5719 matter -- try to find one with known shape, if possible. */
5721 if (array
->value
.op
.op1
->rank
== 0)
5722 replacement
= array
->value
.op
.op2
;
5723 else if (array
->value
.op
.op2
->rank
== 0)
5724 replacement
= array
->value
.op
.op1
;
5727 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
5731 replacement
= array
->value
.op
.op2
;
5736 /* Try to reduce it directly if possible. */
5737 simplified
= simplify_size (replacement
, dim
, k
);
5739 /* Otherwise, we build a new SIZE call. This is hopefully at least
5740 simpler than the original one. */
5743 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
5744 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
5745 GFC_ISYM_SIZE
, "size",
5747 gfc_copy_expr (replacement
),
5748 gfc_copy_expr (dim
),
5756 if (!gfc_array_size (array
, &size
))
5761 if (dim
->expr_type
!= EXPR_CONSTANT
)
5764 d
= mpz_get_ui (dim
->value
.integer
) - 1;
5765 if (!gfc_array_dimen_size (array
, d
, &size
))
5769 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
5770 mpz_set (return_value
->value
.integer
, size
);
5773 return return_value
;
5778 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5781 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
5784 return &gfc_bad_expr
;
5786 result
= simplify_size (array
, dim
, k
);
5787 if (result
== NULL
|| result
== &gfc_bad_expr
)
5790 return range_check (result
, "SIZE");
5794 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
5795 multiplied by the array size. */
5798 gfc_simplify_sizeof (gfc_expr
*x
)
5800 gfc_expr
*result
= NULL
;
5803 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
5806 if (x
->ts
.type
== BT_CHARACTER
5807 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
5808 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
5811 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
5812 && !gfc_array_size (x
, &array_size
))
5815 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
5817 mpz_set_si (result
->value
.integer
, gfc_target_expr_size (x
));
5823 /* STORAGE_SIZE returns the size in bits of a single array element. */
5826 gfc_simplify_storage_size (gfc_expr
*x
,
5829 gfc_expr
*result
= NULL
;
5832 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
5835 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
5836 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
5837 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
5840 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
5842 return &gfc_bad_expr
;
5844 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
5847 mpz_set_si (result
->value
.integer
, gfc_element_size (x
));
5849 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
5851 return range_check (result
, "STORAGE_SIZE");
5856 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
5860 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
5863 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5868 mpz_abs (result
->value
.integer
, x
->value
.integer
);
5869 if (mpz_sgn (y
->value
.integer
) < 0)
5870 mpz_neg (result
->value
.integer
, result
->value
.integer
);
5874 if (gfc_option
.flag_sign_zero
)
5875 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
5878 mpfr_setsign (result
->value
.real
, x
->value
.real
,
5879 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
5883 gfc_internal_error ("Bad type in gfc_simplify_sign");
5891 gfc_simplify_sin (gfc_expr
*x
)
5895 if (x
->expr_type
!= EXPR_CONSTANT
)
5898 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5903 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5907 gfc_set_model (x
->value
.real
);
5908 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5912 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5915 return range_check (result
, "SIN");
5920 gfc_simplify_sinh (gfc_expr
*x
)
5924 if (x
->expr_type
!= EXPR_CONSTANT
)
5927 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5932 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5936 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5943 return range_check (result
, "SINH");
5947 /* The argument is always a double precision real that is converted to
5948 single precision. TODO: Rounding! */
5951 gfc_simplify_sngl (gfc_expr
*a
)
5955 if (a
->expr_type
!= EXPR_CONSTANT
)
5958 result
= gfc_real2real (a
, gfc_default_real_kind
);
5959 return range_check (result
, "SNGL");
5964 gfc_simplify_spacing (gfc_expr
*x
)
5970 if (x
->expr_type
!= EXPR_CONSTANT
)
5973 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5975 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5977 /* Special case x = 0 and -0. */
5978 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5979 if (mpfr_sgn (result
->value
.real
) == 0)
5981 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
5985 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
5986 are the radix, exponent of x, and precision. This excludes the
5987 possibility of subnormal numbers. Fortran 2003 states the result is
5988 b**max(e - p, emin - 1). */
5990 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
5991 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
5992 en
= en
> ep
? en
: ep
;
5994 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
5995 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
5997 return range_check (result
, "SPACING");
6002 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
6004 gfc_expr
*result
= 0L;
6005 int i
, j
, dim
, ncopies
;
6008 if ((!gfc_is_constant_expr (source
)
6009 && !is_constant_array_expr (source
))
6010 || !gfc_is_constant_expr (dim_expr
)
6011 || !gfc_is_constant_expr (ncopies_expr
))
6014 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
6015 gfc_extract_int (dim_expr
, &dim
);
6016 dim
-= 1; /* zero-base DIM */
6018 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
6019 gfc_extract_int (ncopies_expr
, &ncopies
);
6020 ncopies
= MAX (ncopies
, 0);
6022 /* Do not allow the array size to exceed the limit for an array
6024 if (source
->expr_type
== EXPR_ARRAY
)
6026 if (!gfc_array_size (source
, &size
))
6027 gfc_internal_error ("Failure getting length of a constant array.");
6030 mpz_init_set_ui (size
, 1);
6032 if (mpz_get_si (size
)*ncopies
> gfc_option
.flag_max_array_constructor
)
6035 if (source
->expr_type
== EXPR_CONSTANT
)
6037 gcc_assert (dim
== 0);
6039 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6041 if (source
->ts
.type
== BT_DERIVED
)
6042 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6044 result
->shape
= gfc_get_shape (result
->rank
);
6045 mpz_init_set_si (result
->shape
[0], ncopies
);
6047 for (i
= 0; i
< ncopies
; ++i
)
6048 gfc_constructor_append_expr (&result
->value
.constructor
,
6049 gfc_copy_expr (source
), NULL
);
6051 else if (source
->expr_type
== EXPR_ARRAY
)
6053 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
6054 gfc_constructor
*source_ctor
;
6056 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
6057 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
6059 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6061 if (source
->ts
.type
== BT_DERIVED
)
6062 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6063 result
->rank
= source
->rank
+ 1;
6064 result
->shape
= gfc_get_shape (result
->rank
);
6066 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
6069 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
6071 mpz_init_set_si (result
->shape
[i
], ncopies
);
6073 extent
[i
] = mpz_get_si (result
->shape
[i
]);
6074 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
6078 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
6079 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
6081 for (i
= 0; i
< ncopies
; ++i
)
6082 gfc_constructor_insert_expr (&result
->value
.constructor
,
6083 gfc_copy_expr (source_ctor
->expr
),
6084 NULL
, offset
+ i
* rstride
[dim
]);
6086 offset
+= (dim
== 0 ? ncopies
: 1);
6090 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
6091 Replace NULL with gcc_unreachable() after implementing
6092 gfc_simplify_cshift(). */
6095 if (source
->ts
.type
== BT_CHARACTER
)
6096 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
6103 gfc_simplify_sqrt (gfc_expr
*e
)
6105 gfc_expr
*result
= NULL
;
6107 if (e
->expr_type
!= EXPR_CONSTANT
)
6113 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
6115 gfc_error ("Argument of SQRT at %L has a negative value",
6117 return &gfc_bad_expr
;
6119 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6120 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6124 gfc_set_model (e
->value
.real
);
6126 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6127 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
6131 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
6134 return range_check (result
, "SQRT");
6139 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6141 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
6146 gfc_simplify_tan (gfc_expr
*x
)
6150 if (x
->expr_type
!= EXPR_CONSTANT
)
6153 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6158 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6162 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6169 return range_check (result
, "TAN");
6174 gfc_simplify_tanh (gfc_expr
*x
)
6178 if (x
->expr_type
!= EXPR_CONSTANT
)
6181 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6186 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6190 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6197 return range_check (result
, "TANH");
6202 gfc_simplify_tiny (gfc_expr
*e
)
6207 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
6209 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6210 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6217 gfc_simplify_trailz (gfc_expr
*e
)
6219 unsigned long tz
, bs
;
6222 if (e
->expr_type
!= EXPR_CONSTANT
)
6225 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6226 bs
= gfc_integer_kinds
[i
].bit_size
;
6227 tz
= mpz_scan1 (e
->value
.integer
, 0);
6229 return gfc_get_int_expr (gfc_default_integer_kind
,
6230 &e
->where
, MIN (tz
, bs
));
6235 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6238 gfc_expr
*mold_element
;
6243 unsigned char *buffer
;
6244 size_t result_length
;
6247 if (!gfc_is_constant_expr (source
)
6248 || (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
6249 || !gfc_is_constant_expr (size
))
6252 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6253 &result_size
, &result_length
))
6256 /* Calculate the size of the source. */
6257 if (source
->expr_type
== EXPR_ARRAY
6258 && !gfc_array_size (source
, &tmp
))
6259 gfc_internal_error ("Failure getting length of a constant array.");
6261 /* Create an empty new expression with the appropriate characteristics. */
6262 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
6264 result
->ts
= mold
->ts
;
6266 mold_element
= mold
->expr_type
== EXPR_ARRAY
6267 ? gfc_constructor_first (mold
->value
.constructor
)->expr
6270 /* Set result character length, if needed. Note that this needs to be
6271 set even for array expressions, in order to pass this information into
6272 gfc_target_interpret_expr. */
6273 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
6274 result
->value
.character
.length
= mold_element
->value
.character
.length
;
6276 /* Set the number of elements in the result, and determine its size. */
6278 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
6280 result
->expr_type
= EXPR_ARRAY
;
6282 result
->shape
= gfc_get_shape (1);
6283 mpz_init_set_ui (result
->shape
[0], result_length
);
6288 /* Allocate the buffer to store the binary version of the source. */
6289 buffer_size
= MAX (source_size
, result_size
);
6290 buffer
= (unsigned char*)alloca (buffer_size
);
6291 memset (buffer
, 0, buffer_size
);
6293 /* Now write source to the buffer. */
6294 gfc_target_encode_expr (source
, buffer
, buffer_size
);
6296 /* And read the buffer back into the new expression. */
6297 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
6304 gfc_simplify_transpose (gfc_expr
*matrix
)
6306 int row
, matrix_rows
, col
, matrix_cols
;
6309 if (!is_constant_array_expr (matrix
))
6312 gcc_assert (matrix
->rank
== 2);
6314 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
6317 result
->shape
= gfc_get_shape (result
->rank
);
6318 mpz_set (result
->shape
[0], matrix
->shape
[1]);
6319 mpz_set (result
->shape
[1], matrix
->shape
[0]);
6321 if (matrix
->ts
.type
== BT_CHARACTER
)
6322 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
6323 else if (matrix
->ts
.type
== BT_DERIVED
)
6324 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
6326 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
6327 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
6328 for (row
= 0; row
< matrix_rows
; ++row
)
6329 for (col
= 0; col
< matrix_cols
; ++col
)
6331 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
6332 col
* matrix_rows
+ row
);
6333 gfc_constructor_insert_expr (&result
->value
.constructor
,
6334 gfc_copy_expr (e
), &matrix
->where
,
6335 row
* matrix_cols
+ col
);
6343 gfc_simplify_trim (gfc_expr
*e
)
6346 int count
, i
, len
, lentrim
;
6348 if (e
->expr_type
!= EXPR_CONSTANT
)
6351 len
= e
->value
.character
.length
;
6352 for (count
= 0, i
= 1; i
<= len
; ++i
)
6354 if (e
->value
.character
.string
[len
- i
] == ' ')
6360 lentrim
= len
- count
;
6362 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
6363 for (i
= 0; i
< lentrim
; i
++)
6364 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
6371 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
6376 gfc_constructor
*sub_cons
;
6380 if (!is_constant_array_expr (sub
))
6383 /* Follow any component references. */
6384 as
= coarray
->symtree
->n
.sym
->as
;
6385 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
6386 if (ref
->type
== REF_COMPONENT
)
6389 if (as
->type
== AS_DEFERRED
)
6392 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6393 the cosubscript addresses the first image. */
6395 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
6398 for (d
= 1; d
<= as
->corank
; d
++)
6403 gcc_assert (sub_cons
!= NULL
);
6405 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
6407 if (ca_bound
== NULL
)
6410 if (ca_bound
== &gfc_bad_expr
)
6413 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
6417 gfc_free_expr (ca_bound
);
6418 sub_cons
= gfc_constructor_next (sub_cons
);
6422 first_image
= false;
6426 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6427 "SUB has %ld and COARRAY lower bound is %ld)",
6429 mpz_get_si (sub_cons
->expr
->value
.integer
),
6430 mpz_get_si (ca_bound
->value
.integer
));
6431 gfc_free_expr (ca_bound
);
6432 return &gfc_bad_expr
;
6435 gfc_free_expr (ca_bound
);
6437 /* Check whether upperbound is valid for the multi-images case. */
6440 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
6442 if (ca_bound
== &gfc_bad_expr
)
6445 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
6446 && mpz_cmp (ca_bound
->value
.integer
,
6447 sub_cons
->expr
->value
.integer
) < 0)
6449 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6450 "SUB has %ld and COARRAY upper bound is %ld)",
6452 mpz_get_si (sub_cons
->expr
->value
.integer
),
6453 mpz_get_si (ca_bound
->value
.integer
));
6454 gfc_free_expr (ca_bound
);
6455 return &gfc_bad_expr
;
6459 gfc_free_expr (ca_bound
);
6462 sub_cons
= gfc_constructor_next (sub_cons
);
6465 gcc_assert (sub_cons
== NULL
);
6467 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
6470 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6471 &gfc_current_locus
);
6473 mpz_set_si (result
->value
.integer
, 1);
6475 mpz_set_si (result
->value
.integer
, 0);
6482 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
6483 gfc_expr
*distance ATTRIBUTE_UNUSED
)
6485 if (gfc_option
.coarray
!= GFC_FCOARRAY_SINGLE
)
6488 /* If no coarray argument has been passed or when the first argument
6489 is actually a distance argment. */
6490 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
6493 /* FIXME: gfc_current_locus is wrong. */
6494 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6495 &gfc_current_locus
);
6496 mpz_set_si (result
->value
.integer
, 1);
6500 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
6501 return simplify_cobound (coarray
, dim
, NULL
, 0);
6506 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6508 return simplify_bound (array
, dim
, kind
, 1);
6512 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6514 return simplify_cobound (array
, dim
, kind
, 1);
6519 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6521 gfc_expr
*result
, *e
;
6522 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
6524 if (!is_constant_array_expr (vector
)
6525 || !is_constant_array_expr (mask
)
6526 || (!gfc_is_constant_expr (field
)
6527 && !is_constant_array_expr (field
)))
6530 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
6532 if (vector
->ts
.type
== BT_DERIVED
)
6533 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
6534 result
->rank
= mask
->rank
;
6535 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
6537 if (vector
->ts
.type
== BT_CHARACTER
)
6538 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
6540 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
6541 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6543 = field
->expr_type
== EXPR_ARRAY
6544 ? gfc_constructor_first (field
->value
.constructor
)
6549 if (mask_ctor
->expr
->value
.logical
)
6551 gcc_assert (vector_ctor
);
6552 e
= gfc_copy_expr (vector_ctor
->expr
);
6553 vector_ctor
= gfc_constructor_next (vector_ctor
);
6555 else if (field
->expr_type
== EXPR_ARRAY
)
6556 e
= gfc_copy_expr (field_ctor
->expr
);
6558 e
= gfc_copy_expr (field
);
6560 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
6562 mask_ctor
= gfc_constructor_next (mask_ctor
);
6563 field_ctor
= gfc_constructor_next (field_ctor
);
6571 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
6575 size_t index
, len
, lenset
;
6577 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
6580 return &gfc_bad_expr
;
6582 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
6583 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
6586 if (b
!= NULL
&& b
->value
.logical
!= 0)
6591 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
6593 len
= s
->value
.character
.length
;
6594 lenset
= set
->value
.character
.length
;
6598 mpz_set_ui (result
->value
.integer
, 0);
6606 mpz_set_ui (result
->value
.integer
, 1);
6610 index
= wide_strspn (s
->value
.character
.string
,
6611 set
->value
.character
.string
) + 1;
6620 mpz_set_ui (result
->value
.integer
, len
);
6623 for (index
= len
; index
> 0; index
--)
6625 for (i
= 0; i
< lenset
; i
++)
6627 if (s
->value
.character
.string
[index
- 1]
6628 == set
->value
.character
.string
[i
])
6636 mpz_set_ui (result
->value
.integer
, index
);
6642 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
6647 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6650 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6655 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6656 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6657 return range_check (result
, "XOR");
6660 return gfc_get_logical_expr (kind
, &x
->where
,
6661 (x
->value
.logical
&& !y
->value
.logical
)
6662 || (!x
->value
.logical
&& y
->value
.logical
));
6670 /****************** Constant simplification *****************/
6672 /* Master function to convert one constant to another. While this is
6673 used as a simplification function, it requires the destination type
6674 and kind information which is supplied by a special case in
6678 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
6680 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
6695 f
= gfc_int2complex
;
6715 f
= gfc_real2complex
;
6726 f
= gfc_complex2int
;
6729 f
= gfc_complex2real
;
6732 f
= gfc_complex2complex
;
6758 f
= gfc_hollerith2int
;
6762 f
= gfc_hollerith2real
;
6766 f
= gfc_hollerith2complex
;
6770 f
= gfc_hollerith2character
;
6774 f
= gfc_hollerith2logical
;
6784 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6789 switch (e
->expr_type
)
6792 result
= f (e
, kind
);
6794 return &gfc_bad_expr
;
6798 if (!gfc_is_constant_expr (e
))
6801 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6802 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6803 result
->rank
= e
->rank
;
6805 for (c
= gfc_constructor_first (e
->value
.constructor
);
6806 c
; c
= gfc_constructor_next (c
))
6809 if (c
->iterator
== NULL
)
6810 tmp
= f (c
->expr
, kind
);
6813 g
= gfc_convert_constant (c
->expr
, type
, kind
);
6814 if (g
== &gfc_bad_expr
)
6816 gfc_free_expr (result
);
6824 gfc_free_expr (result
);
6828 gfc_constructor_append_expr (&result
->value
.constructor
,
6842 /* Function for converting character constants. */
6844 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
6849 if (!gfc_is_constant_expr (e
))
6852 if (e
->expr_type
== EXPR_CONSTANT
)
6854 /* Simple case of a scalar. */
6855 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
6857 return &gfc_bad_expr
;
6859 result
->value
.character
.length
= e
->value
.character
.length
;
6860 result
->value
.character
.string
6861 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
6862 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
6863 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
6865 /* Check we only have values representable in the destination kind. */
6866 for (i
= 0; i
< result
->value
.character
.length
; i
++)
6867 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
6870 gfc_error ("Character '%s' in string at %L cannot be converted "
6871 "into character kind %d",
6872 gfc_print_wide_char (result
->value
.character
.string
[i
]),
6874 return &gfc_bad_expr
;
6879 else if (e
->expr_type
== EXPR_ARRAY
)
6881 /* For an array constructor, we convert each constructor element. */
6884 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6885 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6886 result
->rank
= e
->rank
;
6887 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
6889 for (c
= gfc_constructor_first (e
->value
.constructor
);
6890 c
; c
= gfc_constructor_next (c
))
6892 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
6893 if (tmp
== &gfc_bad_expr
)
6895 gfc_free_expr (result
);
6896 return &gfc_bad_expr
;
6901 gfc_free_expr (result
);
6905 gfc_constructor_append_expr (&result
->value
.constructor
,
6917 gfc_simplify_compiler_options (void)
6922 str
= gfc_get_option_string ();
6923 result
= gfc_get_character_expr (gfc_default_character_kind
,
6924 &gfc_current_locus
, str
, strlen (str
));
6931 gfc_simplify_compiler_version (void)
6936 len
= strlen ("GCC version ") + strlen (version_string
);
6937 buffer
= XALLOCAVEC (char, len
+ 1);
6938 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
6939 return gfc_get_character_expr (gfc_default_character_kind
,
6940 &gfc_current_locus
, buffer
, len
);