1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2015 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
26 #include "intrinsic.h"
27 #include "target-memory.h"
28 #include "constructor.h"
29 #include "tm.h" /* For BITS_PER_UNIT. */
30 #include "version.h" /* For version_string. */
33 gfc_expr gfc_bad_expr
;
35 static gfc_expr
*simplify_size (gfc_expr
*, gfc_expr
*, int);
38 /* Note that 'simplification' is not just transforming expressions.
39 For functions that are not simplified at compile time, range
40 checking is done if possible.
42 The return convention is that each simplification function returns:
44 A new expression node corresponding to the simplified arguments.
45 The original arguments are destroyed by the caller, and must not
46 be a part of the new expression.
48 NULL pointer indicating that no simplification was possible and
49 the original expression should remain intact.
51 An expression pointer to gfc_bad_expr (a static placeholder)
52 indicating that some error has prevented simplification. The
53 error is generated within the function and should be propagated
56 By the time a simplification function gets control, it has been
57 decided that the function call is really supposed to be the
58 intrinsic. No type checking is strictly necessary, since only
59 valid types will be passed on. On the other hand, a simplification
60 subroutine may have to look at the type of an argument as part of
63 Array arguments are only passed to these subroutines that implement
64 the simplification of transformational intrinsics.
66 The functions in this file don't have much comment with them, but
67 everything is reasonably straight-forward. The Standard, chapter 13
68 is the best comment you'll find for this file anyway. */
70 /* Range checks an expression node. If all goes well, returns the
71 node, otherwise returns &gfc_bad_expr and frees the node. */
74 range_check (gfc_expr
*result
, const char *name
)
79 if (result
->expr_type
!= EXPR_CONSTANT
)
82 switch (gfc_range_check (result
))
88 gfc_error ("Result of %s overflows its kind at %L", name
,
93 gfc_error ("Result of %s underflows its kind at %L", name
,
98 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
102 gfc_error ("Result of %s gives range error for its kind at %L", name
,
107 gfc_free_expr (result
);
108 return &gfc_bad_expr
;
112 /* A helper function that gets an optional and possibly missing
113 kind parameter. Returns the kind, -1 if something went wrong. */
116 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
123 if (k
->expr_type
!= EXPR_CONSTANT
)
125 gfc_error ("KIND parameter of %s at %L must be an initialization "
126 "expression", name
, &k
->where
);
130 if (gfc_extract_int (k
, &kind
) != NULL
131 || gfc_validate_kind (type
, kind
, true) < 0)
133 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
141 /* Converts an mpz_t signed variable into an unsigned one, assuming
142 two's complement representations and a binary width of bitsize.
143 The conversion is a no-op unless x is negative; otherwise, it can
144 be accomplished by masking out the high bits. */
147 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
153 /* Confirm that no bits above the signed range are unset if we
154 are doing range checking. */
155 if (flag_range_check
!= 0)
156 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
158 mpz_init_set_ui (mask
, 1);
159 mpz_mul_2exp (mask
, mask
, bitsize
);
160 mpz_sub_ui (mask
, mask
, 1);
162 mpz_and (x
, x
, mask
);
168 /* Confirm that no bits above the signed range are set. */
169 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
174 /* Converts an mpz_t unsigned variable into a signed one, assuming
175 two's complement representations and a binary width of bitsize.
176 If the bitsize-1 bit is set, this is taken as a sign bit and
177 the number is converted to the corresponding negative number. */
180 gfc_convert_mpz_to_signed (mpz_t x
, int bitsize
)
184 /* Confirm that no bits above the unsigned range are set if we are
185 doing range checking. */
186 if (flag_range_check
!= 0)
187 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
189 if (mpz_tstbit (x
, bitsize
- 1) == 1)
191 mpz_init_set_ui (mask
, 1);
192 mpz_mul_2exp (mask
, mask
, bitsize
);
193 mpz_sub_ui (mask
, mask
, 1);
195 /* We negate the number by hand, zeroing the high bits, that is
196 make it the corresponding positive number, and then have it
197 negated by GMP, giving the correct representation of the
200 mpz_add_ui (x
, x
, 1);
201 mpz_and (x
, x
, mask
);
210 /* In-place convert BOZ to REAL of the specified kind. */
213 convert_boz (gfc_expr
*x
, int kind
)
215 if (x
&& x
->ts
.type
== BT_INTEGER
&& x
->is_boz
)
222 if (!gfc_convert_boz (x
, &ts
))
223 return &gfc_bad_expr
;
230 /* Test that the expression is an constant array. */
233 is_constant_array_expr (gfc_expr
*e
)
240 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
243 for (c
= gfc_constructor_first (e
->value
.constructor
);
244 c
; c
= gfc_constructor_next (c
))
245 if (c
->expr
->expr_type
!= EXPR_CONSTANT
246 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
253 /* Initialize a transformational result expression with a given value. */
256 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
258 if (e
&& e
->expr_type
== EXPR_ARRAY
)
260 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
263 init_result_expr (ctor
->expr
, init
, array
);
264 ctor
= gfc_constructor_next (ctor
);
267 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
269 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
276 e
->value
.logical
= (init
? 1 : 0);
281 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
282 else if (init
== INT_MAX
)
283 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
285 mpz_set_si (e
->value
.integer
, init
);
291 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
292 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
294 else if (init
== INT_MAX
)
295 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
297 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
301 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
307 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
308 gfc_extract_int (len
, &length
);
309 string
= gfc_get_wide_string (length
+ 1);
310 gfc_wide_memset (string
, 0, length
);
312 else if (init
== INT_MAX
)
314 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
315 gfc_extract_int (len
, &length
);
316 string
= gfc_get_wide_string (length
+ 1);
317 gfc_wide_memset (string
, 255, length
);
322 string
= gfc_get_wide_string (1);
325 string
[length
] = '\0';
326 e
->value
.character
.length
= length
;
327 e
->value
.character
.string
= string
;
339 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
340 if conj_a is true, the matrix_a is complex conjugated. */
343 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
344 gfc_expr
*matrix_b
, int stride_b
, int offset_b
,
347 gfc_expr
*result
, *a
, *b
, *c
;
349 result
= gfc_get_constant_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
351 init_result_expr (result
, 0, NULL
);
353 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
354 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
357 /* Copying of expressions is required as operands are free'd
358 by the gfc_arith routines. */
359 switch (result
->ts
.type
)
362 result
= gfc_or (result
,
363 gfc_and (gfc_copy_expr (a
),
370 if (conj_a
&& a
->ts
.type
== BT_COMPLEX
)
371 c
= gfc_simplify_conjg (a
);
373 c
= gfc_copy_expr (a
);
374 result
= gfc_add (result
, gfc_multiply (c
, gfc_copy_expr (b
)));
381 offset_a
+= stride_a
;
382 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
384 offset_b
+= stride_b
;
385 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
392 /* Build a result expression for transformational intrinsics,
396 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
397 int kind
, locus
* where
)
402 if (!dim
|| array
->rank
== 1)
403 return gfc_get_constant_expr (type
, kind
, where
);
405 result
= gfc_get_array_expr (type
, kind
, where
);
406 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
407 result
->rank
= array
->rank
- 1;
409 /* gfc_array_size() would count the number of elements in the constructor,
410 we have not built those yet. */
412 for (i
= 0; i
< result
->rank
; ++i
)
413 nelem
*= mpz_get_ui (result
->shape
[i
]);
415 for (i
= 0; i
< nelem
; ++i
)
417 gfc_constructor_append_expr (&result
->value
.constructor
,
418 gfc_get_constant_expr (type
, kind
, where
),
426 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
428 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
429 of COUNT intrinsic is .TRUE..
431 Interface and implementation mimics arith functions as
432 gfc_add, gfc_multiply, etc. */
434 static gfc_expr
* gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
438 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
439 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
440 gcc_assert (op2
->value
.logical
);
442 result
= gfc_copy_expr (op1
);
443 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
451 /* Transforms an ARRAY with operation OP, according to MASK, to a
452 scalar RESULT. E.g. called if
454 REAL, PARAMETER :: array(n, m) = ...
455 REAL, PARAMETER :: s = SUM(array)
457 where OP == gfc_add(). */
460 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
461 transformational_op op
)
464 gfc_constructor
*array_ctor
, *mask_ctor
;
466 /* Shortcut for constant .FALSE. MASK. */
468 && mask
->expr_type
== EXPR_CONSTANT
469 && !mask
->value
.logical
)
472 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
474 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
475 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
479 a
= array_ctor
->expr
;
480 array_ctor
= gfc_constructor_next (array_ctor
);
482 /* A constant MASK equals .TRUE. here and can be ignored. */
486 mask_ctor
= gfc_constructor_next (mask_ctor
);
487 if (!m
->value
.logical
)
491 result
= op (result
, gfc_copy_expr (a
));
497 /* Transforms an ARRAY with operation OP, according to MASK, to an
498 array RESULT. E.g. called if
500 REAL, PARAMETER :: array(n, m) = ...
501 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
503 where OP == gfc_multiply().
504 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
&& warn_surprising
&& mpz_cmp_si (e
->value
.integer
, 127) > 0)
718 gfc_warning (OPT_Wsurprising
,
719 "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_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
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
&& 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
&& !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
)
1888 if (!is_constant_array_expr (vector_a
)
1889 || !is_constant_array_expr (vector_b
))
1892 gcc_assert (vector_a
->rank
== 1);
1893 gcc_assert (vector_b
->rank
== 1);
1895 temp
.expr_type
= EXPR_OP
;
1896 gfc_clear_ts (&temp
.ts
);
1897 temp
.value
.op
.op
= INTRINSIC_NONE
;
1898 temp
.value
.op
.op1
= vector_a
;
1899 temp
.value
.op
.op2
= vector_b
;
1900 gfc_type_convert_binary (&temp
, 1);
1902 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
1907 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
1909 gfc_expr
*a1
, *a2
, *result
;
1911 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1914 a1
= gfc_real2real (x
, gfc_default_double_kind
);
1915 a2
= gfc_real2real (y
, gfc_default_double_kind
);
1917 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
1918 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
1923 return range_check (result
, "DPROD");
1928 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
1932 int i
, k
, size
, shift
;
1934 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
1935 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
1938 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
1939 size
= gfc_integer_kinds
[k
].bit_size
;
1941 gfc_extract_int (shiftarg
, &shift
);
1943 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
1945 shift
= size
- shift
;
1947 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
1948 mpz_set_ui (result
->value
.integer
, 0);
1950 for (i
= 0; i
< shift
; i
++)
1951 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
1952 mpz_setbit (result
->value
.integer
, i
);
1954 for (i
= 0; i
< size
- shift
; i
++)
1955 if (mpz_tstbit (arg1
->value
.integer
, i
))
1956 mpz_setbit (result
->value
.integer
, shift
+ i
);
1958 /* Convert to a signed value. */
1959 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
1966 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
1968 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
1973 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
1975 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
1980 gfc_simplify_erf (gfc_expr
*x
)
1984 if (x
->expr_type
!= EXPR_CONSTANT
)
1987 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1988 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1990 return range_check (result
, "ERF");
1995 gfc_simplify_erfc (gfc_expr
*x
)
1999 if (x
->expr_type
!= EXPR_CONSTANT
)
2002 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2003 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2005 return range_check (result
, "ERFC");
2009 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2011 #define MAX_ITER 200
2012 #define ARG_LIMIT 12
2014 /* Calculate ERFC_SCALED directly by its definition:
2016 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2018 using a large precision for intermediate results. This is used for all
2019 but large values of the argument. */
2021 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2026 prec
= mpfr_get_default_prec ();
2027 mpfr_set_default_prec (10 * prec
);
2032 mpfr_set (a
, arg
, GFC_RND_MODE
);
2033 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2034 mpfr_exp (b
, b
, GFC_RND_MODE
);
2035 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2036 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2038 mpfr_set (res
, a
, GFC_RND_MODE
);
2039 mpfr_set_default_prec (prec
);
2045 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2047 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2048 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2051 This is used for large values of the argument. Intermediate calculations
2052 are performed with twice the precision. We don't do a fixed number of
2053 iterations of the sum, but stop when it has converged to the required
2056 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2058 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2063 prec
= mpfr_get_default_prec ();
2064 mpfr_set_default_prec (2 * prec
);
2074 mpfr_init (sumtrunc
);
2075 mpfr_set_prec (oldsum
, prec
);
2076 mpfr_set_prec (sumtrunc
, prec
);
2078 mpfr_set (x
, arg
, GFC_RND_MODE
);
2079 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2080 mpz_set_ui (num
, 1);
2082 mpfr_set (u
, x
, GFC_RND_MODE
);
2083 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2084 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2085 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2087 for (i
= 1; i
< MAX_ITER
; i
++)
2089 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2091 mpz_mul_ui (num
, num
, 2 * i
- 1);
2094 mpfr_set (w
, u
, GFC_RND_MODE
);
2095 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2097 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2098 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2100 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2102 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2103 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2107 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2109 gcc_assert (i
< MAX_ITER
);
2111 /* Divide by x * sqrt(Pi). */
2112 mpfr_const_pi (u
, GFC_RND_MODE
);
2113 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2114 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2115 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2117 mpfr_set (res
, sum
, GFC_RND_MODE
);
2118 mpfr_set_default_prec (prec
);
2120 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2126 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2130 if (x
->expr_type
!= EXPR_CONSTANT
)
2133 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2134 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2135 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2137 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2139 return range_check (result
, "ERFC_SCALED");
2147 gfc_simplify_epsilon (gfc_expr
*e
)
2152 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2154 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2155 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2157 return range_check (result
, "EPSILON");
2162 gfc_simplify_exp (gfc_expr
*x
)
2166 if (x
->expr_type
!= EXPR_CONSTANT
)
2169 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2174 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2178 gfc_set_model_kind (x
->ts
.kind
);
2179 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2183 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2186 return range_check (result
, "EXP");
2191 gfc_simplify_exponent (gfc_expr
*x
)
2196 if (x
->expr_type
!= EXPR_CONSTANT
)
2199 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2202 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2203 if (mpfr_inf_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
2205 int i
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
2206 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2210 /* EXPONENT(+/- 0.0) = 0 */
2211 if (mpfr_zero_p (x
->value
.real
))
2213 mpz_set_ui (result
->value
.integer
, 0);
2217 gfc_set_model (x
->value
.real
);
2219 val
= (long int) mpfr_get_exp (x
->value
.real
);
2220 mpz_set_si (result
->value
.integer
, val
);
2222 return range_check (result
, "EXPONENT");
2227 gfc_simplify_float (gfc_expr
*a
)
2231 if (a
->expr_type
!= EXPR_CONSTANT
)
2236 if (convert_boz (a
, gfc_default_real_kind
) == &gfc_bad_expr
)
2237 return &gfc_bad_expr
;
2239 result
= gfc_copy_expr (a
);
2242 result
= gfc_int2real (a
, gfc_default_real_kind
);
2244 return range_check (result
, "FLOAT");
2249 is_last_ref_vtab (gfc_expr
*e
)
2252 gfc_component
*comp
= NULL
;
2254 if (e
->expr_type
!= EXPR_VARIABLE
)
2257 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2258 if (ref
->type
== REF_COMPONENT
)
2259 comp
= ref
->u
.c
.component
;
2261 if (!e
->ref
|| !comp
)
2262 return e
->symtree
->n
.sym
->attr
.vtab
;
2264 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
2272 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
2274 /* Avoid simplification of resolved symbols. */
2275 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
2278 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
2279 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2280 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2283 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
2286 /* Return .false. if the dynamic type can never be the same. */
2287 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
2288 && !gfc_type_is_extension_of
2289 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2290 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
2291 && !gfc_type_is_extension_of
2292 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
2293 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
2294 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
2295 && !gfc_type_is_extension_of
2297 mold
->ts
.u
.derived
->components
->ts
.u
.derived
)
2298 && !gfc_type_is_extension_of
2299 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2301 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
2302 && !gfc_type_is_extension_of
2303 (mold
->ts
.u
.derived
,
2304 a
->ts
.u
.derived
->components
->ts
.u
.derived
)))
2305 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2307 if (mold
->ts
.type
== BT_DERIVED
2308 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2309 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
2310 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
2317 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
2319 /* Avoid simplification of resolved symbols. */
2320 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
2323 /* Return .false. if the dynamic type can never be the
2325 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
2326 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
2327 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
2328 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
2329 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2331 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
2334 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2335 gfc_compare_derived_types (a
->ts
.u
.derived
,
2341 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
2347 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
2349 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2351 if (e
->expr_type
!= EXPR_CONSTANT
)
2354 mpfr_init2 (floor
, mpfr_get_prec (e
->value
.real
));
2355 mpfr_floor (floor
, e
->value
.real
);
2357 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
2358 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
2362 return range_check (result
, "FLOOR");
2367 gfc_simplify_fraction (gfc_expr
*x
)
2371 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2372 mpfr_t absv
, exp
, pow2
;
2377 if (x
->expr_type
!= EXPR_CONSTANT
)
2380 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
2382 /* FRACTION(inf) = NaN. */
2383 if (mpfr_inf_p (x
->value
.real
))
2385 mpfr_set_nan (result
->value
.real
);
2389 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2391 /* MPFR versions before 3.1.0 do not include mpfr_frexp.
2392 TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
2394 if (mpfr_sgn (x
->value
.real
) == 0)
2396 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2400 gfc_set_model_kind (x
->ts
.kind
);
2405 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
2406 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
2408 mpfr_trunc (exp
, exp
);
2409 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
2411 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
2413 mpfr_div (result
->value
.real
, x
->value
.real
, pow2
, GFC_RND_MODE
);
2415 mpfr_clears (exp
, absv
, pow2
, NULL
);
2419 /* mpfr_frexp() correctly handles zeros and NaNs. */
2420 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2424 return range_check (result
, "FRACTION");
2429 gfc_simplify_gamma (gfc_expr
*x
)
2433 if (x
->expr_type
!= EXPR_CONSTANT
)
2436 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2437 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2439 return range_check (result
, "GAMMA");
2444 gfc_simplify_huge (gfc_expr
*e
)
2449 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2450 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2455 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2459 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
2471 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
2475 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2478 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2479 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
2480 return range_check (result
, "HYPOT");
2484 /* We use the processor's collating sequence, because all
2485 systems that gfortran currently works on are ASCII. */
2488 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
2494 if (e
->expr_type
!= EXPR_CONSTANT
)
2497 if (e
->value
.character
.length
!= 1)
2499 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
2500 return &gfc_bad_expr
;
2503 index
= e
->value
.character
.string
[0];
2505 if (warn_surprising
&& index
> 127)
2506 gfc_warning (OPT_Wsurprising
,
2507 "Argument of IACHAR function at %L outside of range 0..127",
2510 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
2512 return &gfc_bad_expr
;
2514 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2516 return range_check (result
, "IACHAR");
2521 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
2523 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2524 gcc_assert (result
->ts
.type
== BT_INTEGER
2525 && result
->expr_type
== EXPR_CONSTANT
);
2527 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2533 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2535 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
2540 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
2542 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2543 gcc_assert (result
->ts
.type
== BT_INTEGER
2544 && result
->expr_type
== EXPR_CONSTANT
);
2546 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2552 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2554 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
2559 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
2563 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2566 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2567 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2569 return range_check (result
, "IAND");
2574 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
2579 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2582 gfc_extract_int (y
, &pos
);
2584 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2586 result
= gfc_copy_expr (x
);
2588 convert_mpz_to_unsigned (result
->value
.integer
,
2589 gfc_integer_kinds
[k
].bit_size
);
2591 mpz_clrbit (result
->value
.integer
, pos
);
2593 gfc_convert_mpz_to_signed (result
->value
.integer
,
2594 gfc_integer_kinds
[k
].bit_size
);
2601 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
2608 if (x
->expr_type
!= EXPR_CONSTANT
2609 || y
->expr_type
!= EXPR_CONSTANT
2610 || z
->expr_type
!= EXPR_CONSTANT
)
2613 gfc_extract_int (y
, &pos
);
2614 gfc_extract_int (z
, &len
);
2616 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
2618 bitsize
= gfc_integer_kinds
[k
].bit_size
;
2620 if (pos
+ len
> bitsize
)
2622 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2623 "bit size at %L", &y
->where
);
2624 return &gfc_bad_expr
;
2627 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2628 convert_mpz_to_unsigned (result
->value
.integer
,
2629 gfc_integer_kinds
[k
].bit_size
);
2631 bits
= XCNEWVEC (int, bitsize
);
2633 for (i
= 0; i
< bitsize
; i
++)
2636 for (i
= 0; i
< len
; i
++)
2637 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
2639 for (i
= 0; i
< bitsize
; i
++)
2642 mpz_clrbit (result
->value
.integer
, i
);
2643 else if (bits
[i
] == 1)
2644 mpz_setbit (result
->value
.integer
, i
);
2646 gfc_internal_error ("IBITS: Bad bit");
2651 gfc_convert_mpz_to_signed (result
->value
.integer
,
2652 gfc_integer_kinds
[k
].bit_size
);
2659 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
2664 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2667 gfc_extract_int (y
, &pos
);
2669 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2671 result
= gfc_copy_expr (x
);
2673 convert_mpz_to_unsigned (result
->value
.integer
,
2674 gfc_integer_kinds
[k
].bit_size
);
2676 mpz_setbit (result
->value
.integer
, pos
);
2678 gfc_convert_mpz_to_signed (result
->value
.integer
,
2679 gfc_integer_kinds
[k
].bit_size
);
2686 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
2692 if (e
->expr_type
!= EXPR_CONSTANT
)
2695 if (e
->value
.character
.length
!= 1)
2697 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
2698 return &gfc_bad_expr
;
2701 index
= e
->value
.character
.string
[0];
2703 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
2705 return &gfc_bad_expr
;
2707 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2709 return range_check (result
, "ICHAR");
2714 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
2718 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2721 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2722 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2724 return range_check (result
, "IEOR");
2729 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
2732 int back
, len
, lensub
;
2733 int i
, j
, k
, count
, index
= 0, start
;
2735 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
2736 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
2739 if (b
!= NULL
&& b
->value
.logical
!= 0)
2744 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
2746 return &gfc_bad_expr
;
2748 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
2750 len
= x
->value
.character
.length
;
2751 lensub
= y
->value
.character
.length
;
2755 mpz_set_si (result
->value
.integer
, 0);
2763 mpz_set_si (result
->value
.integer
, 1);
2766 else if (lensub
== 1)
2768 for (i
= 0; i
< len
; i
++)
2770 for (j
= 0; j
< lensub
; j
++)
2772 if (y
->value
.character
.string
[j
]
2773 == x
->value
.character
.string
[i
])
2783 for (i
= 0; i
< len
; i
++)
2785 for (j
= 0; j
< lensub
; j
++)
2787 if (y
->value
.character
.string
[j
]
2788 == x
->value
.character
.string
[i
])
2793 for (k
= 0; k
< lensub
; k
++)
2795 if (y
->value
.character
.string
[k
]
2796 == x
->value
.character
.string
[k
+ start
])
2800 if (count
== lensub
)
2815 mpz_set_si (result
->value
.integer
, len
+ 1);
2818 else if (lensub
== 1)
2820 for (i
= 0; i
< len
; i
++)
2822 for (j
= 0; j
< lensub
; j
++)
2824 if (y
->value
.character
.string
[j
]
2825 == x
->value
.character
.string
[len
- i
])
2827 index
= len
- i
+ 1;
2835 for (i
= 0; i
< len
; i
++)
2837 for (j
= 0; j
< lensub
; j
++)
2839 if (y
->value
.character
.string
[j
]
2840 == x
->value
.character
.string
[len
- i
])
2843 if (start
<= len
- lensub
)
2846 for (k
= 0; k
< lensub
; k
++)
2847 if (y
->value
.character
.string
[k
]
2848 == x
->value
.character
.string
[k
+ start
])
2851 if (count
== lensub
)
2868 mpz_set_si (result
->value
.integer
, index
);
2869 return range_check (result
, "INDEX");
2874 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
2876 gfc_expr
*result
= NULL
;
2878 if (e
->expr_type
!= EXPR_CONSTANT
)
2881 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
2882 if (result
== &gfc_bad_expr
)
2883 return &gfc_bad_expr
;
2885 return range_check (result
, name
);
2890 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
2894 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
2896 return &gfc_bad_expr
;
2898 return simplify_intconv (e
, kind
, "INT");
2902 gfc_simplify_int2 (gfc_expr
*e
)
2904 return simplify_intconv (e
, 2, "INT2");
2909 gfc_simplify_int8 (gfc_expr
*e
)
2911 return simplify_intconv (e
, 8, "INT8");
2916 gfc_simplify_long (gfc_expr
*e
)
2918 return simplify_intconv (e
, 4, "LONG");
2923 gfc_simplify_ifix (gfc_expr
*e
)
2925 gfc_expr
*rtrunc
, *result
;
2927 if (e
->expr_type
!= EXPR_CONSTANT
)
2930 rtrunc
= gfc_copy_expr (e
);
2931 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
2933 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2935 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
2937 gfc_free_expr (rtrunc
);
2939 return range_check (result
, "IFIX");
2944 gfc_simplify_idint (gfc_expr
*e
)
2946 gfc_expr
*rtrunc
, *result
;
2948 if (e
->expr_type
!= EXPR_CONSTANT
)
2951 rtrunc
= gfc_copy_expr (e
);
2952 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
2954 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2956 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
2958 gfc_free_expr (rtrunc
);
2960 return range_check (result
, "IDINT");
2965 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
2969 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2972 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2973 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2975 return range_check (result
, "IOR");
2980 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
2982 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2983 gcc_assert (result
->ts
.type
== BT_INTEGER
2984 && result
->expr_type
== EXPR_CONSTANT
);
2986 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2992 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2994 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
2999 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3001 if (x
->expr_type
!= EXPR_CONSTANT
)
3004 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3005 mpz_cmp_si (x
->value
.integer
,
3006 LIBERROR_END
) == 0);
3011 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3013 if (x
->expr_type
!= EXPR_CONSTANT
)
3016 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3017 mpz_cmp_si (x
->value
.integer
,
3018 LIBERROR_EOR
) == 0);
3023 gfc_simplify_isnan (gfc_expr
*x
)
3025 if (x
->expr_type
!= EXPR_CONSTANT
)
3028 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3029 mpfr_nan_p (x
->value
.real
));
3033 /* Performs a shift on its first argument. Depending on the last
3034 argument, the shift can be arithmetic, i.e. with filling from the
3035 left like in the SHIFTA intrinsic. */
3037 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3038 bool arithmetic
, int direction
)
3041 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3043 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3046 gfc_extract_int (s
, &shift
);
3048 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3049 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3051 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3055 mpz_set (result
->value
.integer
, e
->value
.integer
);
3059 if (direction
> 0 && shift
< 0)
3061 /* Left shift, as in SHIFTL. */
3062 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3063 return &gfc_bad_expr
;
3065 else if (direction
< 0)
3067 /* Right shift, as in SHIFTR or SHIFTA. */
3070 gfc_error ("Second argument of %s is negative at %L",
3072 return &gfc_bad_expr
;
3078 ashift
= (shift
>= 0 ? shift
: -shift
);
3080 if (ashift
> bitsize
)
3082 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3083 "at %L", name
, &e
->where
);
3084 return &gfc_bad_expr
;
3087 bits
= XCNEWVEC (int, bitsize
);
3089 for (i
= 0; i
< bitsize
; i
++)
3090 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3095 for (i
= 0; i
< shift
; i
++)
3096 mpz_clrbit (result
->value
.integer
, i
);
3098 for (i
= 0; i
< bitsize
- shift
; i
++)
3101 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3103 mpz_setbit (result
->value
.integer
, i
+ shift
);
3109 if (arithmetic
&& bits
[bitsize
- 1])
3110 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3111 mpz_setbit (result
->value
.integer
, i
);
3113 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3114 mpz_clrbit (result
->value
.integer
, i
);
3116 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3119 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3121 mpz_setbit (result
->value
.integer
, i
- ashift
);
3125 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3133 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3135 return simplify_shift (e
, s
, "ISHFT", false, 0);
3140 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3142 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3147 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3149 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3154 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3156 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3161 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3163 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3168 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3170 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3175 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3178 int shift
, ashift
, isize
, ssize
, delta
, k
;
3181 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3184 gfc_extract_int (s
, &shift
);
3186 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3187 isize
= gfc_integer_kinds
[k
].bit_size
;
3191 if (sz
->expr_type
!= EXPR_CONSTANT
)
3194 gfc_extract_int (sz
, &ssize
);
3208 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3209 "BIT_SIZE of first argument at %L", &s
->where
);
3210 return &gfc_bad_expr
;
3213 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3215 mpz_set (result
->value
.integer
, e
->value
.integer
);
3220 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
3222 bits
= XCNEWVEC (int, ssize
);
3224 for (i
= 0; i
< ssize
; i
++)
3225 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3227 delta
= ssize
- ashift
;
3231 for (i
= 0; i
< delta
; i
++)
3234 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3236 mpz_setbit (result
->value
.integer
, i
+ shift
);
3239 for (i
= delta
; i
< ssize
; i
++)
3242 mpz_clrbit (result
->value
.integer
, i
- delta
);
3244 mpz_setbit (result
->value
.integer
, i
- delta
);
3249 for (i
= 0; i
< ashift
; i
++)
3252 mpz_clrbit (result
->value
.integer
, i
+ delta
);
3254 mpz_setbit (result
->value
.integer
, i
+ delta
);
3257 for (i
= ashift
; i
< ssize
; i
++)
3260 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3262 mpz_setbit (result
->value
.integer
, i
+ shift
);
3266 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
3274 gfc_simplify_kind (gfc_expr
*e
)
3276 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
3281 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
3282 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
3284 gfc_expr
*l
, *u
, *result
;
3287 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3288 gfc_default_integer_kind
);
3290 return &gfc_bad_expr
;
3292 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3294 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3295 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3296 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
3300 gfc_expr
* dim
= result
;
3301 mpz_set_si (dim
->value
.integer
, d
);
3303 result
= simplify_size (array
, dim
, k
);
3304 gfc_free_expr (dim
);
3309 mpz_set_si (result
->value
.integer
, 1);
3314 /* Otherwise, we have a variable expression. */
3315 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
3318 if (!gfc_resolve_array_spec (as
, 0))
3321 /* The last dimension of an assumed-size array is special. */
3322 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
3323 || (coarray
&& d
== as
->rank
+ as
->corank
3324 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
3326 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
3328 gfc_free_expr (result
);
3329 return gfc_copy_expr (as
->lower
[d
-1]);
3335 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3337 /* Then, we need to know the extent of the given dimension. */
3338 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
3340 gfc_expr
*declared_bound
;
3342 bool constant_lbound
, constant_ubound
;
3347 gcc_assert (l
!= NULL
);
3349 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
3350 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
3352 empty_bound
= upper
? 0 : 1;
3353 declared_bound
= upper
? u
: l
;
3355 if ((!upper
&& !constant_lbound
)
3356 || (upper
&& !constant_ubound
))
3361 /* For {L,U}BOUND, the value depends on whether the array
3362 is empty. We can nevertheless simplify if the declared bound
3363 has the same value as that of an empty array, in which case
3364 the result isn't dependent on the array emptyness. */
3365 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
3366 mpz_set_si (result
->value
.integer
, empty_bound
);
3367 else if (!constant_lbound
|| !constant_ubound
)
3368 /* Array emptyness can't be determined, we can't simplify. */
3370 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
3371 mpz_set_si (result
->value
.integer
, empty_bound
);
3373 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
3376 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
3382 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d
- 1, &result
->value
.integer
, NULL
))
3386 mpz_set_si (result
->value
.integer
, (long int) 1);
3390 return range_check (result
, upper
? "UBOUND" : "LBOUND");
3393 gfc_free_expr (result
);
3399 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3405 if (array
->ts
.type
== BT_CLASS
)
3408 if (array
->expr_type
!= EXPR_VARIABLE
)
3415 /* Follow any component references. */
3416 as
= array
->symtree
->n
.sym
->as
;
3417 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3422 switch (ref
->u
.ar
.type
)
3429 /* We're done because 'as' has already been set in the
3430 previous iteration. */
3444 as
= ref
->u
.c
.component
->as
;
3456 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
3457 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
3461 || (as
->type
!= AS_DEFERRED
3462 && array
->expr_type
== EXPR_VARIABLE
3463 && !gfc_expr_attr (array
).allocatable
3464 && !gfc_expr_attr (array
).pointer
));
3468 /* Multi-dimensional bounds. */
3469 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3473 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
3474 if (upper
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
3476 /* An error message will be emitted in
3477 check_assumed_size_reference (resolve.c). */
3478 return &gfc_bad_expr
;
3481 /* Simplify the bounds for each dimension. */
3482 for (d
= 0; d
< array
->rank
; d
++)
3484 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
3486 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3490 for (j
= 0; j
< d
; j
++)
3491 gfc_free_expr (bounds
[j
]);
3496 /* Allocate the result expression. */
3497 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3498 gfc_default_integer_kind
);
3500 return &gfc_bad_expr
;
3502 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
3504 /* The result is a rank 1 array; its size is the rank of the first
3505 argument to {L,U}BOUND. */
3507 e
->shape
= gfc_get_shape (1);
3508 mpz_init_set_ui (e
->shape
[0], array
->rank
);
3510 /* Create the constructor for this array. */
3511 for (d
= 0; d
< array
->rank
; d
++)
3512 gfc_constructor_append_expr (&e
->value
.constructor
,
3513 bounds
[d
], &e
->where
);
3519 /* A DIM argument is specified. */
3520 if (dim
->expr_type
!= EXPR_CONSTANT
)
3523 d
= mpz_get_si (dim
->value
.integer
);
3525 if ((d
< 1 || d
> array
->rank
)
3526 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
3528 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3529 return &gfc_bad_expr
;
3532 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3535 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
3541 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3547 if (array
->expr_type
!= EXPR_VARIABLE
)
3550 /* Follow any component references. */
3551 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
3552 ? array
->ts
.u
.derived
->components
->as
3553 : array
->symtree
->n
.sym
->as
;
3554 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3559 switch (ref
->u
.ar
.type
)
3562 if (ref
->u
.ar
.as
->corank
> 0)
3564 gcc_assert (as
== ref
->u
.ar
.as
);
3571 /* We're done because 'as' has already been set in the
3572 previous iteration. */
3586 as
= ref
->u
.c
.component
->as
;
3599 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
3604 /* Multi-dimensional cobounds. */
3605 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3609 /* Simplify the cobounds for each dimension. */
3610 for (d
= 0; d
< as
->corank
; d
++)
3612 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
3613 upper
, as
, ref
, true);
3614 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3618 for (j
= 0; j
< d
; j
++)
3619 gfc_free_expr (bounds
[j
]);
3624 /* Allocate the result expression. */
3625 e
= gfc_get_expr ();
3626 e
->where
= array
->where
;
3627 e
->expr_type
= EXPR_ARRAY
;
3628 e
->ts
.type
= BT_INTEGER
;
3629 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
3630 gfc_default_integer_kind
);
3634 return &gfc_bad_expr
;
3638 /* The result is a rank 1 array; its size is the rank of the first
3639 argument to {L,U}COBOUND. */
3641 e
->shape
= gfc_get_shape (1);
3642 mpz_init_set_ui (e
->shape
[0], as
->corank
);
3644 /* Create the constructor for this array. */
3645 for (d
= 0; d
< as
->corank
; d
++)
3646 gfc_constructor_append_expr (&e
->value
.constructor
,
3647 bounds
[d
], &e
->where
);
3652 /* A DIM argument is specified. */
3653 if (dim
->expr_type
!= EXPR_CONSTANT
)
3656 d
= mpz_get_si (dim
->value
.integer
);
3658 if (d
< 1 || d
> as
->corank
)
3660 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3661 return &gfc_bad_expr
;
3664 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
3670 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3672 return simplify_bound (array
, dim
, kind
, 0);
3677 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3679 return simplify_cobound (array
, dim
, kind
, 0);
3683 gfc_simplify_leadz (gfc_expr
*e
)
3685 unsigned long lz
, bs
;
3688 if (e
->expr_type
!= EXPR_CONSTANT
)
3691 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3692 bs
= gfc_integer_kinds
[i
].bit_size
;
3693 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
3695 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
3698 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
3700 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
3705 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
3708 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
3711 return &gfc_bad_expr
;
3713 if (e
->expr_type
== EXPR_CONSTANT
)
3715 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3716 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
3717 return range_check (result
, "LEN");
3719 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
3720 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3721 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
3723 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3724 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
3725 return range_check (result
, "LEN");
3727 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
3728 && e
->symtree
->n
.sym
3729 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
3730 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
)
3731 /* The expression in assoc->target points to a ref to the _data component
3732 of the unlimited polymorphic entity. To get the _len component the last
3733 _data ref needs to be stripped and a ref to the _len component added. */
3734 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
);
3741 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
3745 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
3748 return &gfc_bad_expr
;
3750 if (e
->expr_type
!= EXPR_CONSTANT
)
3753 len
= e
->value
.character
.length
;
3754 for (count
= 0, i
= 1; i
<= len
; i
++)
3755 if (e
->value
.character
.string
[len
- i
] == ' ')
3760 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
3761 return range_check (result
, "LEN_TRIM");
3765 gfc_simplify_lgamma (gfc_expr
*x
)
3770 if (x
->expr_type
!= EXPR_CONSTANT
)
3773 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3774 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
3776 return range_check (result
, "LGAMMA");
3781 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
3783 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3786 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3787 gfc_compare_string (a
, b
) >= 0);
3792 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
3794 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3797 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3798 gfc_compare_string (a
, b
) > 0);
3803 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
3805 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3808 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3809 gfc_compare_string (a
, b
) <= 0);
3814 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
3816 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3819 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3820 gfc_compare_string (a
, b
) < 0);
3825 gfc_simplify_log (gfc_expr
*x
)
3829 if (x
->expr_type
!= EXPR_CONSTANT
)
3832 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3837 if (mpfr_sgn (x
->value
.real
) <= 0)
3839 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3840 "to zero", &x
->where
);
3841 gfc_free_expr (result
);
3842 return &gfc_bad_expr
;
3845 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3849 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
3850 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
3852 gfc_error ("Complex argument of LOG at %L cannot be zero",
3854 gfc_free_expr (result
);
3855 return &gfc_bad_expr
;
3858 gfc_set_model_kind (x
->ts
.kind
);
3859 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
3863 gfc_internal_error ("gfc_simplify_log: bad type");
3866 return range_check (result
, "LOG");
3871 gfc_simplify_log10 (gfc_expr
*x
)
3875 if (x
->expr_type
!= EXPR_CONSTANT
)
3878 if (mpfr_sgn (x
->value
.real
) <= 0)
3880 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3881 "to zero", &x
->where
);
3882 return &gfc_bad_expr
;
3885 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3886 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3888 return range_check (result
, "LOG10");
3893 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
3897 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
3899 return &gfc_bad_expr
;
3901 if (e
->expr_type
!= EXPR_CONSTANT
)
3904 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
3909 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
3912 int row
, result_rows
, col
, result_columns
;
3913 int stride_a
, offset_a
, stride_b
, offset_b
;
3915 if (!is_constant_array_expr (matrix_a
)
3916 || !is_constant_array_expr (matrix_b
))
3919 gcc_assert (gfc_compare_types (&matrix_a
->ts
, &matrix_b
->ts
));
3920 result
= gfc_get_array_expr (matrix_a
->ts
.type
,
3924 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
3927 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
3929 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
3932 result
->shape
= gfc_get_shape (result
->rank
);
3933 mpz_init_set_si (result
->shape
[0], result_columns
);
3935 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
3937 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
3939 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
3943 result
->shape
= gfc_get_shape (result
->rank
);
3944 mpz_init_set_si (result
->shape
[0], result_rows
);
3946 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
3948 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
3949 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
3950 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
3951 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
3954 result
->shape
= gfc_get_shape (result
->rank
);
3955 mpz_init_set_si (result
->shape
[0], result_rows
);
3956 mpz_init_set_si (result
->shape
[1], result_columns
);
3961 offset_a
= offset_b
= 0;
3962 for (col
= 0; col
< result_columns
; ++col
)
3966 for (row
= 0; row
< result_rows
; ++row
)
3968 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
3969 matrix_b
, 1, offset_b
, false);
3970 gfc_constructor_append_expr (&result
->value
.constructor
,
3976 offset_b
+= stride_b
;
3984 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
3990 if (i
->expr_type
!= EXPR_CONSTANT
)
3993 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
3995 return &gfc_bad_expr
;
3996 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
3998 s
= gfc_extract_int (i
, &arg
);
4001 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4003 /* MASKR(n) = 2^n - 1 */
4004 mpz_set_ui (result
->value
.integer
, 1);
4005 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4006 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4008 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4015 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4022 if (i
->expr_type
!= EXPR_CONSTANT
)
4025 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4027 return &gfc_bad_expr
;
4028 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4030 s
= gfc_extract_int (i
, &arg
);
4033 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4035 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4036 mpz_init_set_ui (z
, 1);
4037 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4038 mpz_set_ui (result
->value
.integer
, 1);
4039 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4040 gfc_integer_kinds
[k
].bit_size
- arg
);
4041 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4044 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4051 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4054 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4056 if (mask
->expr_type
== EXPR_CONSTANT
)
4057 return gfc_get_parentheses (gfc_copy_expr (mask
->value
.logical
4058 ? tsource
: fsource
));
4060 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4061 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4064 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4066 if (tsource
->ts
.type
== BT_DERIVED
)
4067 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4068 else if (tsource
->ts
.type
== BT_CHARACTER
)
4069 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4071 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4072 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4073 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4077 if (mask_ctor
->expr
->value
.logical
)
4078 gfc_constructor_append_expr (&result
->value
.constructor
,
4079 gfc_copy_expr (tsource_ctor
->expr
),
4082 gfc_constructor_append_expr (&result
->value
.constructor
,
4083 gfc_copy_expr (fsource_ctor
->expr
),
4085 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4086 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4087 mask_ctor
= gfc_constructor_next (mask_ctor
);
4090 result
->shape
= gfc_get_shape (1);
4091 gfc_array_size (result
, &result
->shape
[0]);
4098 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4100 mpz_t arg1
, arg2
, mask
;
4103 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4104 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4107 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4109 /* Convert all argument to unsigned. */
4110 mpz_init_set (arg1
, i
->value
.integer
);
4111 mpz_init_set (arg2
, j
->value
.integer
);
4112 mpz_init_set (mask
, mask_expr
->value
.integer
);
4114 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4115 mpz_and (arg1
, arg1
, mask
);
4116 mpz_com (mask
, mask
);
4117 mpz_and (arg2
, arg2
, mask
);
4118 mpz_ior (result
->value
.integer
, arg1
, arg2
);
4128 /* Selects between current value and extremum for simplify_min_max
4129 and simplify_minval_maxval. */
4131 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
)
4133 switch (arg
->ts
.type
)
4136 if (mpz_cmp (arg
->value
.integer
,
4137 extremum
->value
.integer
) * sign
> 0)
4138 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
4142 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4144 mpfr_max (extremum
->value
.real
, extremum
->value
.real
,
4145 arg
->value
.real
, GFC_RND_MODE
);
4147 mpfr_min (extremum
->value
.real
, extremum
->value
.real
,
4148 arg
->value
.real
, GFC_RND_MODE
);
4152 #define LENGTH(x) ((x)->value.character.length)
4153 #define STRING(x) ((x)->value.character.string)
4154 if (LENGTH (extremum
) < LENGTH(arg
))
4156 gfc_char_t
*tmp
= STRING(extremum
);
4158 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
4159 memcpy (STRING(extremum
), tmp
,
4160 LENGTH(extremum
) * sizeof (gfc_char_t
));
4161 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
4162 LENGTH(arg
) - LENGTH(extremum
));
4163 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
4164 LENGTH(extremum
) = LENGTH(arg
);
4168 if (gfc_compare_string (arg
, extremum
) * sign
> 0)
4170 free (STRING(extremum
));
4171 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
4172 memcpy (STRING(extremum
), STRING(arg
),
4173 LENGTH(arg
) * sizeof (gfc_char_t
));
4174 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
4175 LENGTH(extremum
) - LENGTH(arg
));
4176 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
4183 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4188 /* This function is special since MAX() can take any number of
4189 arguments. The simplified expression is a rewritten version of the
4190 argument list containing at most one constant element. Other
4191 constant elements are deleted. Because the argument list has
4192 already been checked, this function always succeeds. sign is 1 for
4193 MAX(), -1 for MIN(). */
4196 simplify_min_max (gfc_expr
*expr
, int sign
)
4198 gfc_actual_arglist
*arg
, *last
, *extremum
;
4199 gfc_intrinsic_sym
* specific
;
4203 specific
= expr
->value
.function
.isym
;
4205 arg
= expr
->value
.function
.actual
;
4207 for (; arg
; last
= arg
, arg
= arg
->next
)
4209 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
4212 if (extremum
== NULL
)
4218 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
4220 /* Delete the extra constant argument. */
4221 last
->next
= arg
->next
;
4224 gfc_free_actual_arglist (arg
);
4228 /* If there is one value left, replace the function call with the
4230 if (expr
->value
.function
.actual
->next
!= NULL
)
4233 /* Convert to the correct type and kind. */
4234 if (expr
->ts
.type
!= BT_UNKNOWN
)
4235 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4236 expr
->ts
.type
, expr
->ts
.kind
);
4238 if (specific
->ts
.type
!= BT_UNKNOWN
)
4239 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4240 specific
->ts
.type
, specific
->ts
.kind
);
4242 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
4247 gfc_simplify_min (gfc_expr
*e
)
4249 return simplify_min_max (e
, -1);
4254 gfc_simplify_max (gfc_expr
*e
)
4256 return simplify_min_max (e
, 1);
4260 /* This is a simplified version of simplify_min_max to provide
4261 simplification of minval and maxval for a vector. */
4264 simplify_minval_maxval (gfc_expr
*expr
, int sign
)
4266 gfc_constructor
*c
, *extremum
;
4267 gfc_intrinsic_sym
* specific
;
4270 specific
= expr
->value
.function
.isym
;
4272 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4273 c
; c
= gfc_constructor_next (c
))
4275 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4278 if (extremum
== NULL
)
4284 min_max_choose (c
->expr
, extremum
->expr
, sign
);
4287 if (extremum
== NULL
)
4290 /* Convert to the correct type and kind. */
4291 if (expr
->ts
.type
!= BT_UNKNOWN
)
4292 return gfc_convert_constant (extremum
->expr
,
4293 expr
->ts
.type
, expr
->ts
.kind
);
4295 if (specific
->ts
.type
!= BT_UNKNOWN
)
4296 return gfc_convert_constant (extremum
->expr
,
4297 specific
->ts
.type
, specific
->ts
.kind
);
4299 return gfc_copy_expr (extremum
->expr
);
4304 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4306 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4309 return simplify_minval_maxval (array
, -1);
4314 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4316 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4319 return simplify_minval_maxval (array
, 1);
4324 gfc_simplify_maxexponent (gfc_expr
*x
)
4326 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4327 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4328 gfc_real_kinds
[i
].max_exponent
);
4333 gfc_simplify_minexponent (gfc_expr
*x
)
4335 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4336 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4337 gfc_real_kinds
[i
].min_exponent
);
4342 gfc_simplify_mod (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. */
4359 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
4360 gfc_free_expr (result
);
4361 return &gfc_bad_expr
;
4363 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4367 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4369 /* Result is processor-dependent. */
4370 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
4371 gfc_free_expr (result
);
4372 return &gfc_bad_expr
;
4375 gfc_set_model_kind (kind
);
4376 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4381 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4384 return range_check (result
, "MOD");
4389 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
4394 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4397 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4398 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4403 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4405 /* Result is processor-dependent. This processor just opts
4406 to not handle it at all. */
4407 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
4408 gfc_free_expr (result
);
4409 return &gfc_bad_expr
;
4411 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4416 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4418 /* Result is processor-dependent. */
4419 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
4420 gfc_free_expr (result
);
4421 return &gfc_bad_expr
;
4424 gfc_set_model_kind (kind
);
4425 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4427 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
4429 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
4430 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
4434 mpfr_copysign (result
->value
.real
, result
->value
.real
,
4435 p
->value
.real
, GFC_RND_MODE
);
4439 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4442 return range_check (result
, "MODULO");
4447 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
4450 mp_exp_t emin
, emax
;
4453 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
4456 result
= gfc_copy_expr (x
);
4458 /* Save current values of emin and emax. */
4459 emin
= mpfr_get_emin ();
4460 emax
= mpfr_get_emax ();
4462 /* Set emin and emax for the current model number. */
4463 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
4464 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
4465 mpfr_get_prec(result
->value
.real
) + 1);
4466 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
4467 mpfr_check_range (result
->value
.real
, 0, GMP_RNDU
);
4469 if (mpfr_sgn (s
->value
.real
) > 0)
4471 mpfr_nextabove (result
->value
.real
);
4472 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
4476 mpfr_nextbelow (result
->value
.real
);
4477 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
4480 mpfr_set_emin (emin
);
4481 mpfr_set_emax (emax
);
4483 /* Only NaN can occur. Do not use range check as it gives an
4484 error for denormal numbers. */
4485 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
4487 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
4488 gfc_free_expr (result
);
4489 return &gfc_bad_expr
;
4497 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
4499 gfc_expr
*itrunc
, *result
;
4502 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
4504 return &gfc_bad_expr
;
4506 if (e
->expr_type
!= EXPR_CONSTANT
)
4509 itrunc
= gfc_copy_expr (e
);
4510 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
4512 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
4513 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
4515 gfc_free_expr (itrunc
);
4517 return range_check (result
, name
);
4522 gfc_simplify_new_line (gfc_expr
*e
)
4526 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
4527 result
->value
.character
.string
[0] = '\n';
4534 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
4536 return simplify_nint ("NINT", e
, k
);
4541 gfc_simplify_idnint (gfc_expr
*e
)
4543 return simplify_nint ("IDNINT", e
, NULL
);
4548 add_squared (gfc_expr
*result
, gfc_expr
*e
)
4552 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4553 gcc_assert (result
->ts
.type
== BT_REAL
4554 && result
->expr_type
== EXPR_CONSTANT
);
4556 gfc_set_model_kind (result
->ts
.kind
);
4558 mpfr_pow_ui (tmp
, e
->value
.real
, 2, GFC_RND_MODE
);
4559 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
4568 do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
4570 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4571 gcc_assert (result
->ts
.type
== BT_REAL
4572 && result
->expr_type
== EXPR_CONSTANT
);
4574 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
4575 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4581 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
4585 if (!is_constant_array_expr (e
)
4586 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
4589 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4590 init_result_expr (result
, 0, NULL
);
4592 if (!dim
|| e
->rank
== 1)
4594 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
4596 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4599 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
4600 add_squared
, &do_sqrt
);
4607 gfc_simplify_not (gfc_expr
*e
)
4611 if (e
->expr_type
!= EXPR_CONSTANT
)
4614 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4615 mpz_com (result
->value
.integer
, e
->value
.integer
);
4617 return range_check (result
, "NOT");
4622 gfc_simplify_null (gfc_expr
*mold
)
4628 result
= gfc_copy_expr (mold
);
4629 result
->expr_type
= EXPR_NULL
;
4632 result
= gfc_get_null_expr (NULL
);
4639 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
4643 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4645 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4646 return &gfc_bad_expr
;
4649 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
4652 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
4655 /* FIXME: gfc_current_locus is wrong. */
4656 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
4657 &gfc_current_locus
);
4659 if (failed
&& failed
->value
.logical
!= 0)
4660 mpz_set_si (result
->value
.integer
, 0);
4662 mpz_set_si (result
->value
.integer
, 1);
4669 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
4674 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4677 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4682 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
4683 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4684 return range_check (result
, "OR");
4687 return gfc_get_logical_expr (kind
, &x
->where
,
4688 x
->value
.logical
|| y
->value
.logical
);
4696 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4699 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
4701 if (!is_constant_array_expr (array
)
4702 || !is_constant_array_expr (vector
)
4703 || (!gfc_is_constant_expr (mask
)
4704 && !is_constant_array_expr (mask
)))
4707 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
4708 if (array
->ts
.type
== BT_DERIVED
)
4709 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
4711 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
4712 vector_ctor
= vector
4713 ? gfc_constructor_first (vector
->value
.constructor
)
4716 if (mask
->expr_type
== EXPR_CONSTANT
4717 && mask
->value
.logical
)
4719 /* Copy all elements of ARRAY to RESULT. */
4722 gfc_constructor_append_expr (&result
->value
.constructor
,
4723 gfc_copy_expr (array_ctor
->expr
),
4726 array_ctor
= gfc_constructor_next (array_ctor
);
4727 vector_ctor
= gfc_constructor_next (vector_ctor
);
4730 else if (mask
->expr_type
== EXPR_ARRAY
)
4732 /* Copy only those elements of ARRAY to RESULT whose
4733 MASK equals .TRUE.. */
4734 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4737 if (mask_ctor
->expr
->value
.logical
)
4739 gfc_constructor_append_expr (&result
->value
.constructor
,
4740 gfc_copy_expr (array_ctor
->expr
),
4742 vector_ctor
= gfc_constructor_next (vector_ctor
);
4745 array_ctor
= gfc_constructor_next (array_ctor
);
4746 mask_ctor
= gfc_constructor_next (mask_ctor
);
4750 /* Append any left-over elements from VECTOR to RESULT. */
4753 gfc_constructor_append_expr (&result
->value
.constructor
,
4754 gfc_copy_expr (vector_ctor
->expr
),
4756 vector_ctor
= gfc_constructor_next (vector_ctor
);
4759 result
->shape
= gfc_get_shape (1);
4760 gfc_array_size (result
, &result
->shape
[0]);
4762 if (array
->ts
.type
== BT_CHARACTER
)
4763 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
4770 do_xor (gfc_expr
*result
, gfc_expr
*e
)
4772 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
4773 gcc_assert (result
->ts
.type
== BT_LOGICAL
4774 && result
->expr_type
== EXPR_CONSTANT
);
4776 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
4783 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
4785 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
4790 gfc_simplify_popcnt (gfc_expr
*e
)
4795 if (e
->expr_type
!= EXPR_CONSTANT
)
4798 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4800 /* Convert argument to unsigned, then count the '1' bits. */
4801 mpz_init_set (x
, e
->value
.integer
);
4802 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
4803 res
= mpz_popcount (x
);
4806 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
4811 gfc_simplify_poppar (gfc_expr
*e
)
4817 if (e
->expr_type
!= EXPR_CONSTANT
)
4820 popcnt
= gfc_simplify_popcnt (e
);
4821 gcc_assert (popcnt
);
4823 s
= gfc_extract_int (popcnt
, &i
);
4826 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
4831 gfc_simplify_precision (gfc_expr
*e
)
4833 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4834 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
4835 gfc_real_kinds
[i
].precision
);
4840 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
4842 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
4847 gfc_simplify_radix (gfc_expr
*e
)
4850 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4855 i
= gfc_integer_kinds
[i
].radix
;
4859 i
= gfc_real_kinds
[i
].radix
;
4866 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4871 gfc_simplify_range (gfc_expr
*e
)
4874 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4879 i
= gfc_integer_kinds
[i
].range
;
4884 i
= gfc_real_kinds
[i
].range
;
4891 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4896 gfc_simplify_rank (gfc_expr
*e
)
4902 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
4907 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
4909 gfc_expr
*result
= NULL
;
4912 if (e
->ts
.type
== BT_COMPLEX
)
4913 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
4915 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
4918 return &gfc_bad_expr
;
4920 if (e
->expr_type
!= EXPR_CONSTANT
)
4923 if (convert_boz (e
, kind
) == &gfc_bad_expr
)
4924 return &gfc_bad_expr
;
4926 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
4927 if (result
== &gfc_bad_expr
)
4928 return &gfc_bad_expr
;
4930 return range_check (result
, "REAL");
4935 gfc_simplify_realpart (gfc_expr
*e
)
4939 if (e
->expr_type
!= EXPR_CONSTANT
)
4942 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
4943 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
4945 return range_check (result
, "REALPART");
4949 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
4952 int i
, j
, len
, ncop
, nlen
;
4954 bool have_length
= false;
4956 /* If NCOPIES isn't a constant, there's nothing we can do. */
4957 if (n
->expr_type
!= EXPR_CONSTANT
)
4960 /* If NCOPIES is negative, it's an error. */
4961 if (mpz_sgn (n
->value
.integer
) < 0)
4963 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4965 return &gfc_bad_expr
;
4968 /* If we don't know the character length, we can do no more. */
4969 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
4970 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4972 len
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
4975 else if (e
->expr_type
== EXPR_CONSTANT
4976 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
4978 len
= e
->value
.character
.length
;
4983 /* If the source length is 0, any value of NCOPIES is valid
4984 and everything behaves as if NCOPIES == 0. */
4987 mpz_set_ui (ncopies
, 0);
4989 mpz_set (ncopies
, n
->value
.integer
);
4991 /* Check that NCOPIES isn't too large. */
4997 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
4999 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5003 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
5004 e
->ts
.u
.cl
->length
->value
.integer
);
5008 mpz_init_set_si (mlen
, len
);
5009 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
5013 /* The check itself. */
5014 if (mpz_cmp (ncopies
, max
) > 0)
5017 mpz_clear (ncopies
);
5018 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
5020 return &gfc_bad_expr
;
5025 mpz_clear (ncopies
);
5027 /* For further simplification, we need the character string to be
5029 if (e
->expr_type
!= EXPR_CONSTANT
)
5033 (e
->ts
.u
.cl
->length
&&
5034 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
)) != 0)
5036 const char *res
= gfc_extract_int (n
, &ncop
);
5037 gcc_assert (res
== NULL
);
5043 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
5045 len
= e
->value
.character
.length
;
5048 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
5049 for (i
= 0; i
< ncop
; i
++)
5050 for (j
= 0; j
< len
; j
++)
5051 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
5053 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
5058 /* This one is a bear, but mainly has to do with shuffling elements. */
5061 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
5062 gfc_expr
*pad
, gfc_expr
*order_exp
)
5064 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
5065 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
5069 gfc_expr
*e
, *result
;
5071 /* Check that argument expression types are OK. */
5072 if (!is_constant_array_expr (source
)
5073 || !is_constant_array_expr (shape_exp
)
5074 || !is_constant_array_expr (pad
)
5075 || !is_constant_array_expr (order_exp
))
5078 /* Proceed with simplification, unpacking the array. */
5085 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
5089 gfc_extract_int (e
, &shape
[rank
]);
5091 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
5092 gcc_assert (shape
[rank
] >= 0);
5097 gcc_assert (rank
> 0);
5099 /* Now unpack the order array if present. */
5100 if (order_exp
== NULL
)
5102 for (i
= 0; i
< rank
; i
++)
5107 for (i
= 0; i
< rank
; i
++)
5110 for (i
= 0; i
< rank
; i
++)
5112 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
5115 gfc_extract_int (e
, &order
[i
]);
5117 gcc_assert (order
[i
] >= 1 && order
[i
] <= rank
);
5119 gcc_assert (x
[order
[i
]] == 0);
5124 /* Count the elements in the source and padding arrays. */
5129 gfc_array_size (pad
, &size
);
5130 npad
= mpz_get_ui (size
);
5134 gfc_array_size (source
, &size
);
5135 nsource
= mpz_get_ui (size
);
5138 /* If it weren't for that pesky permutation we could just loop
5139 through the source and round out any shortage with pad elements.
5140 But no, someone just had to have the compiler do something the
5141 user should be doing. */
5143 for (i
= 0; i
< rank
; i
++)
5146 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
5148 if (source
->ts
.type
== BT_DERIVED
)
5149 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
5150 result
->rank
= rank
;
5151 result
->shape
= gfc_get_shape (rank
);
5152 for (i
= 0; i
< rank
; i
++)
5153 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
5155 while (nsource
> 0 || npad
> 0)
5157 /* Figure out which element to extract. */
5158 mpz_set_ui (index
, 0);
5160 for (i
= rank
- 1; i
>= 0; i
--)
5162 mpz_add_ui (index
, index
, x
[order
[i
]]);
5164 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
5167 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
5168 gfc_internal_error ("Reshaped array too large at %C");
5170 j
= mpz_get_ui (index
);
5173 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
5183 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
5187 gfc_constructor_append_expr (&result
->value
.constructor
,
5188 gfc_copy_expr (e
), &e
->where
);
5190 /* Calculate the next element. */
5194 if (++x
[i
] < shape
[i
])
5210 gfc_simplify_rrspacing (gfc_expr
*x
)
5216 if (x
->expr_type
!= EXPR_CONSTANT
)
5219 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5221 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5223 /* RRSPACING(+/- 0.0) = 0.0 */
5224 if (mpfr_zero_p (x
->value
.real
))
5226 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5230 /* RRSPACING(inf) = NaN */
5231 if (mpfr_inf_p (x
->value
.real
))
5233 mpfr_set_nan (result
->value
.real
);
5237 /* RRSPACING(NaN) = same NaN */
5238 if (mpfr_nan_p (x
->value
.real
))
5240 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5244 /* | x * 2**(-e) | * 2**p. */
5245 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5246 e
= - (long int) mpfr_get_exp (x
->value
.real
);
5247 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
5249 p
= (long int) gfc_real_kinds
[i
].digits
;
5250 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
5252 return range_check (result
, "RRSPACING");
5257 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
5259 int k
, neg_flag
, power
, exp_range
;
5260 mpfr_t scale
, radix
;
5263 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5266 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5268 if (mpfr_zero_p (x
->value
.real
))
5270 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5274 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5276 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
5278 /* This check filters out values of i that would overflow an int. */
5279 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
5280 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
5282 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
5283 gfc_free_expr (result
);
5284 return &gfc_bad_expr
;
5287 /* Compute scale = radix ** power. */
5288 power
= mpz_get_si (i
->value
.integer
);
5298 gfc_set_model_kind (x
->ts
.kind
);
5301 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
5302 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
5305 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5307 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5309 mpfr_clears (scale
, radix
, NULL
);
5311 return range_check (result
, "SCALE");
5315 /* Variants of strspn and strcspn that operate on wide characters. */
5318 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5321 const gfc_char_t
*c
;
5325 for (c
= s2
; *c
; c
++)
5339 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5342 const gfc_char_t
*c
;
5346 for (c
= s2
; *c
; c
++)
5361 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
5366 size_t indx
, len
, lenc
;
5367 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
5370 return &gfc_bad_expr
;
5372 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
5373 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
5376 if (b
!= NULL
&& b
->value
.logical
!= 0)
5381 len
= e
->value
.character
.length
;
5382 lenc
= c
->value
.character
.length
;
5384 if (len
== 0 || lenc
== 0)
5392 indx
= wide_strcspn (e
->value
.character
.string
,
5393 c
->value
.character
.string
) + 1;
5400 for (indx
= len
; indx
> 0; indx
--)
5402 for (i
= 0; i
< lenc
; i
++)
5404 if (c
->value
.character
.string
[i
]
5405 == e
->value
.character
.string
[indx
- 1])
5414 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
5415 return range_check (result
, "SCAN");
5420 gfc_simplify_selected_char_kind (gfc_expr
*e
)
5424 if (e
->expr_type
!= EXPR_CONSTANT
)
5427 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
5428 || gfc_compare_with_Cstring (e
, "default", false) == 0)
5430 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
5435 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5440 gfc_simplify_selected_int_kind (gfc_expr
*e
)
5444 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
5449 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
5450 if (gfc_integer_kinds
[i
].range
>= range
5451 && gfc_integer_kinds
[i
].kind
< kind
)
5452 kind
= gfc_integer_kinds
[i
].kind
;
5454 if (kind
== INT_MAX
)
5457 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5462 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
5464 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
5466 locus
*loc
= &gfc_current_locus
;
5472 if (p
->expr_type
!= EXPR_CONSTANT
5473 || gfc_extract_int (p
, &precision
) != NULL
)
5482 if (q
->expr_type
!= EXPR_CONSTANT
5483 || gfc_extract_int (q
, &range
) != NULL
)
5494 if (rdx
->expr_type
!= EXPR_CONSTANT
5495 || gfc_extract_int (rdx
, &radix
) != NULL
)
5503 found_precision
= 0;
5507 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5509 if (gfc_real_kinds
[i
].precision
>= precision
)
5510 found_precision
= 1;
5512 if (gfc_real_kinds
[i
].range
>= range
)
5515 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5518 if (gfc_real_kinds
[i
].precision
>= precision
5519 && gfc_real_kinds
[i
].range
>= range
5520 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5521 && gfc_real_kinds
[i
].kind
< kind
)
5522 kind
= gfc_real_kinds
[i
].kind
;
5525 if (kind
== INT_MAX
)
5527 if (found_radix
&& found_range
&& !found_precision
)
5529 else if (found_radix
&& found_precision
&& !found_range
)
5531 else if (found_radix
&& !found_precision
&& !found_range
)
5533 else if (found_radix
)
5539 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
5544 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5547 mpfr_t exp
, absv
, log2
, pow2
, frac
;
5550 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5553 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5555 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
5556 SET_EXPONENT (NaN) = same NaN */
5557 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
5559 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5563 /* SET_EXPONENT (inf) = NaN */
5564 if (mpfr_inf_p (x
->value
.real
))
5566 mpfr_set_nan (result
->value
.real
);
5570 gfc_set_model_kind (x
->ts
.kind
);
5577 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
5578 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
5580 mpfr_trunc (log2
, log2
);
5581 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
5583 /* Old exponent value, and fraction. */
5584 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
5586 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
5589 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
5590 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
5592 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
5594 return range_check (result
, "SET_EXPONENT");
5599 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
5601 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5602 gfc_expr
*result
, *e
, *f
;
5606 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
5608 if (source
->rank
== -1)
5611 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
5613 if (source
->rank
== 0)
5616 if (source
->expr_type
== EXPR_VARIABLE
)
5618 ar
= gfc_find_array_ref (source
);
5619 t
= gfc_array_ref_shape (ar
, shape
);
5621 else if (source
->shape
)
5624 for (n
= 0; n
< source
->rank
; n
++)
5626 mpz_init (shape
[n
]);
5627 mpz_set (shape
[n
], source
->shape
[n
]);
5633 for (n
= 0; n
< source
->rank
; n
++)
5635 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
5638 mpz_set (e
->value
.integer
, shape
[n
]);
5641 mpz_set_ui (e
->value
.integer
, n
+ 1);
5643 f
= simplify_size (source
, e
, k
);
5647 gfc_free_expr (result
);
5654 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
5656 gfc_free_expr (result
);
5658 gfc_clear_shape (shape
, source
->rank
);
5659 return &gfc_bad_expr
;
5662 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
5666 gfc_clear_shape (shape
, source
->rank
);
5673 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
5676 gfc_expr
*return_value
;
5679 /* For unary operations, the size of the result is given by the size
5680 of the operand. For binary ones, it's the size of the first operand
5681 unless it is scalar, then it is the size of the second. */
5682 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
5684 gfc_expr
* replacement
;
5685 gfc_expr
* simplified
;
5687 switch (array
->value
.op
.op
)
5689 /* Unary operations. */
5691 case INTRINSIC_UPLUS
:
5692 case INTRINSIC_UMINUS
:
5693 case INTRINSIC_PARENTHESES
:
5694 replacement
= array
->value
.op
.op1
;
5697 /* Binary operations. If any one of the operands is scalar, take
5698 the other one's size. If both of them are arrays, it does not
5699 matter -- try to find one with known shape, if possible. */
5701 if (array
->value
.op
.op1
->rank
== 0)
5702 replacement
= array
->value
.op
.op2
;
5703 else if (array
->value
.op
.op2
->rank
== 0)
5704 replacement
= array
->value
.op
.op1
;
5707 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
5711 replacement
= array
->value
.op
.op2
;
5716 /* Try to reduce it directly if possible. */
5717 simplified
= simplify_size (replacement
, dim
, k
);
5719 /* Otherwise, we build a new SIZE call. This is hopefully at least
5720 simpler than the original one. */
5723 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
5724 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
5725 GFC_ISYM_SIZE
, "size",
5727 gfc_copy_expr (replacement
),
5728 gfc_copy_expr (dim
),
5736 if (!gfc_array_size (array
, &size
))
5741 if (dim
->expr_type
!= EXPR_CONSTANT
)
5744 d
= mpz_get_ui (dim
->value
.integer
) - 1;
5745 if (!gfc_array_dimen_size (array
, d
, &size
))
5749 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
5750 mpz_set (return_value
->value
.integer
, size
);
5753 return return_value
;
5758 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5761 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
5764 return &gfc_bad_expr
;
5766 result
= simplify_size (array
, dim
, k
);
5767 if (result
== NULL
|| result
== &gfc_bad_expr
)
5770 return range_check (result
, "SIZE");
5774 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
5775 multiplied by the array size. */
5778 gfc_simplify_sizeof (gfc_expr
*x
)
5780 gfc_expr
*result
= NULL
;
5783 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
5786 if (x
->ts
.type
== BT_CHARACTER
5787 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
5788 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
5791 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
5792 && !gfc_array_size (x
, &array_size
))
5795 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
5797 mpz_set_si (result
->value
.integer
, gfc_target_expr_size (x
));
5803 /* STORAGE_SIZE returns the size in bits of a single array element. */
5806 gfc_simplify_storage_size (gfc_expr
*x
,
5809 gfc_expr
*result
= NULL
;
5812 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
5815 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
5816 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
5817 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
5820 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
5822 return &gfc_bad_expr
;
5824 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
5826 mpz_set_si (result
->value
.integer
, gfc_element_size (x
));
5827 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
5829 return range_check (result
, "STORAGE_SIZE");
5834 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
5838 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
5841 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5846 mpz_abs (result
->value
.integer
, x
->value
.integer
);
5847 if (mpz_sgn (y
->value
.integer
) < 0)
5848 mpz_neg (result
->value
.integer
, result
->value
.integer
);
5853 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
5856 mpfr_setsign (result
->value
.real
, x
->value
.real
,
5857 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
5861 gfc_internal_error ("Bad type in gfc_simplify_sign");
5869 gfc_simplify_sin (gfc_expr
*x
)
5873 if (x
->expr_type
!= EXPR_CONSTANT
)
5876 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5881 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5885 gfc_set_model (x
->value
.real
);
5886 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5890 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5893 return range_check (result
, "SIN");
5898 gfc_simplify_sinh (gfc_expr
*x
)
5902 if (x
->expr_type
!= EXPR_CONSTANT
)
5905 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5910 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5914 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5921 return range_check (result
, "SINH");
5925 /* The argument is always a double precision real that is converted to
5926 single precision. TODO: Rounding! */
5929 gfc_simplify_sngl (gfc_expr
*a
)
5933 if (a
->expr_type
!= EXPR_CONSTANT
)
5936 result
= gfc_real2real (a
, gfc_default_real_kind
);
5937 return range_check (result
, "SNGL");
5942 gfc_simplify_spacing (gfc_expr
*x
)
5948 if (x
->expr_type
!= EXPR_CONSTANT
)
5951 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5952 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5954 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
5955 if (mpfr_zero_p (x
->value
.real
))
5957 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
5961 /* SPACING(inf) = NaN */
5962 if (mpfr_inf_p (x
->value
.real
))
5964 mpfr_set_nan (result
->value
.real
);
5968 /* SPACING(NaN) = same NaN */
5969 if (mpfr_nan_p (x
->value
.real
))
5971 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5975 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
5976 are the radix, exponent of x, and precision. This excludes the
5977 possibility of subnormal numbers. Fortran 2003 states the result is
5978 b**max(e - p, emin - 1). */
5980 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
5981 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
5982 en
= en
> ep
? en
: ep
;
5984 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
5985 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
5987 return range_check (result
, "SPACING");
5992 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
5994 gfc_expr
*result
= 0L;
5995 int i
, j
, dim
, ncopies
;
5998 if ((!gfc_is_constant_expr (source
)
5999 && !is_constant_array_expr (source
))
6000 || !gfc_is_constant_expr (dim_expr
)
6001 || !gfc_is_constant_expr (ncopies_expr
))
6004 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
6005 gfc_extract_int (dim_expr
, &dim
);
6006 dim
-= 1; /* zero-base DIM */
6008 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
6009 gfc_extract_int (ncopies_expr
, &ncopies
);
6010 ncopies
= MAX (ncopies
, 0);
6012 /* Do not allow the array size to exceed the limit for an array
6014 if (source
->expr_type
== EXPR_ARRAY
)
6016 if (!gfc_array_size (source
, &size
))
6017 gfc_internal_error ("Failure getting length of a constant array.");
6020 mpz_init_set_ui (size
, 1);
6022 if (mpz_get_si (size
)*ncopies
> flag_max_array_constructor
)
6025 if (source
->expr_type
== EXPR_CONSTANT
)
6027 gcc_assert (dim
== 0);
6029 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6031 if (source
->ts
.type
== BT_DERIVED
)
6032 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6034 result
->shape
= gfc_get_shape (result
->rank
);
6035 mpz_init_set_si (result
->shape
[0], ncopies
);
6037 for (i
= 0; i
< ncopies
; ++i
)
6038 gfc_constructor_append_expr (&result
->value
.constructor
,
6039 gfc_copy_expr (source
), NULL
);
6041 else if (source
->expr_type
== EXPR_ARRAY
)
6043 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
6044 gfc_constructor
*source_ctor
;
6046 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
6047 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
6049 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6051 if (source
->ts
.type
== BT_DERIVED
)
6052 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6053 result
->rank
= source
->rank
+ 1;
6054 result
->shape
= gfc_get_shape (result
->rank
);
6056 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
6059 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
6061 mpz_init_set_si (result
->shape
[i
], ncopies
);
6063 extent
[i
] = mpz_get_si (result
->shape
[i
]);
6064 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
6068 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
6069 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
6071 for (i
= 0; i
< ncopies
; ++i
)
6072 gfc_constructor_insert_expr (&result
->value
.constructor
,
6073 gfc_copy_expr (source_ctor
->expr
),
6074 NULL
, offset
+ i
* rstride
[dim
]);
6076 offset
+= (dim
== 0 ? ncopies
: 1);
6080 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
6081 Replace NULL with gcc_unreachable() after implementing
6082 gfc_simplify_cshift(). */
6085 if (source
->ts
.type
== BT_CHARACTER
)
6086 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
6093 gfc_simplify_sqrt (gfc_expr
*e
)
6095 gfc_expr
*result
= NULL
;
6097 if (e
->expr_type
!= EXPR_CONSTANT
)
6103 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
6105 gfc_error ("Argument of SQRT at %L has a negative value",
6107 return &gfc_bad_expr
;
6109 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6110 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6114 gfc_set_model (e
->value
.real
);
6116 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6117 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
6121 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
6124 return range_check (result
, "SQRT");
6129 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6131 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
6136 gfc_simplify_tan (gfc_expr
*x
)
6140 if (x
->expr_type
!= EXPR_CONSTANT
)
6143 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6148 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6152 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6159 return range_check (result
, "TAN");
6164 gfc_simplify_tanh (gfc_expr
*x
)
6168 if (x
->expr_type
!= EXPR_CONSTANT
)
6171 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6176 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6180 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6187 return range_check (result
, "TANH");
6192 gfc_simplify_tiny (gfc_expr
*e
)
6197 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
6199 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6200 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6207 gfc_simplify_trailz (gfc_expr
*e
)
6209 unsigned long tz
, bs
;
6212 if (e
->expr_type
!= EXPR_CONSTANT
)
6215 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6216 bs
= gfc_integer_kinds
[i
].bit_size
;
6217 tz
= mpz_scan1 (e
->value
.integer
, 0);
6219 return gfc_get_int_expr (gfc_default_integer_kind
,
6220 &e
->where
, MIN (tz
, bs
));
6225 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6228 gfc_expr
*mold_element
;
6233 unsigned char *buffer
;
6234 size_t result_length
;
6237 if (!gfc_is_constant_expr (source
)
6238 || (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
6239 || !gfc_is_constant_expr (size
))
6242 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6243 &result_size
, &result_length
))
6246 /* Calculate the size of the source. */
6247 if (source
->expr_type
== EXPR_ARRAY
6248 && !gfc_array_size (source
, &tmp
))
6249 gfc_internal_error ("Failure getting length of a constant array.");
6251 /* Create an empty new expression with the appropriate characteristics. */
6252 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
6254 result
->ts
= mold
->ts
;
6256 mold_element
= mold
->expr_type
== EXPR_ARRAY
6257 ? gfc_constructor_first (mold
->value
.constructor
)->expr
6260 /* Set result character length, if needed. Note that this needs to be
6261 set even for array expressions, in order to pass this information into
6262 gfc_target_interpret_expr. */
6263 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
6264 result
->value
.character
.length
= mold_element
->value
.character
.length
;
6266 /* Set the number of elements in the result, and determine its size. */
6268 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
6270 result
->expr_type
= EXPR_ARRAY
;
6272 result
->shape
= gfc_get_shape (1);
6273 mpz_init_set_ui (result
->shape
[0], result_length
);
6278 /* Allocate the buffer to store the binary version of the source. */
6279 buffer_size
= MAX (source_size
, result_size
);
6280 buffer
= (unsigned char*)alloca (buffer_size
);
6281 memset (buffer
, 0, buffer_size
);
6283 /* Now write source to the buffer. */
6284 gfc_target_encode_expr (source
, buffer
, buffer_size
);
6286 /* And read the buffer back into the new expression. */
6287 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
6294 gfc_simplify_transpose (gfc_expr
*matrix
)
6296 int row
, matrix_rows
, col
, matrix_cols
;
6299 if (!is_constant_array_expr (matrix
))
6302 gcc_assert (matrix
->rank
== 2);
6304 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
6307 result
->shape
= gfc_get_shape (result
->rank
);
6308 mpz_set (result
->shape
[0], matrix
->shape
[1]);
6309 mpz_set (result
->shape
[1], matrix
->shape
[0]);
6311 if (matrix
->ts
.type
== BT_CHARACTER
)
6312 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
6313 else if (matrix
->ts
.type
== BT_DERIVED
)
6314 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
6316 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
6317 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
6318 for (row
= 0; row
< matrix_rows
; ++row
)
6319 for (col
= 0; col
< matrix_cols
; ++col
)
6321 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
6322 col
* matrix_rows
+ row
);
6323 gfc_constructor_insert_expr (&result
->value
.constructor
,
6324 gfc_copy_expr (e
), &matrix
->where
,
6325 row
* matrix_cols
+ col
);
6333 gfc_simplify_trim (gfc_expr
*e
)
6336 int count
, i
, len
, lentrim
;
6338 if (e
->expr_type
!= EXPR_CONSTANT
)
6341 len
= e
->value
.character
.length
;
6342 for (count
= 0, i
= 1; i
<= len
; ++i
)
6344 if (e
->value
.character
.string
[len
- i
] == ' ')
6350 lentrim
= len
- count
;
6352 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
6353 for (i
= 0; i
< lentrim
; i
++)
6354 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
6361 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
6366 gfc_constructor
*sub_cons
;
6370 if (!is_constant_array_expr (sub
))
6373 /* Follow any component references. */
6374 as
= coarray
->symtree
->n
.sym
->as
;
6375 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
6376 if (ref
->type
== REF_COMPONENT
)
6379 if (as
->type
== AS_DEFERRED
)
6382 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6383 the cosubscript addresses the first image. */
6385 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
6388 for (d
= 1; d
<= as
->corank
; d
++)
6393 gcc_assert (sub_cons
!= NULL
);
6395 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
6397 if (ca_bound
== NULL
)
6400 if (ca_bound
== &gfc_bad_expr
)
6403 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
6407 gfc_free_expr (ca_bound
);
6408 sub_cons
= gfc_constructor_next (sub_cons
);
6412 first_image
= false;
6416 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6417 "SUB has %ld and COARRAY lower bound is %ld)",
6419 mpz_get_si (sub_cons
->expr
->value
.integer
),
6420 mpz_get_si (ca_bound
->value
.integer
));
6421 gfc_free_expr (ca_bound
);
6422 return &gfc_bad_expr
;
6425 gfc_free_expr (ca_bound
);
6427 /* Check whether upperbound is valid for the multi-images case. */
6430 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
6432 if (ca_bound
== &gfc_bad_expr
)
6435 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
6436 && mpz_cmp (ca_bound
->value
.integer
,
6437 sub_cons
->expr
->value
.integer
) < 0)
6439 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6440 "SUB has %ld and COARRAY upper bound is %ld)",
6442 mpz_get_si (sub_cons
->expr
->value
.integer
),
6443 mpz_get_si (ca_bound
->value
.integer
));
6444 gfc_free_expr (ca_bound
);
6445 return &gfc_bad_expr
;
6449 gfc_free_expr (ca_bound
);
6452 sub_cons
= gfc_constructor_next (sub_cons
);
6455 gcc_assert (sub_cons
== NULL
);
6457 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
6460 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6461 &gfc_current_locus
);
6463 mpz_set_si (result
->value
.integer
, 1);
6465 mpz_set_si (result
->value
.integer
, 0);
6472 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
6473 gfc_expr
*distance ATTRIBUTE_UNUSED
)
6475 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6478 /* If no coarray argument has been passed or when the first argument
6479 is actually a distance argment. */
6480 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
6483 /* FIXME: gfc_current_locus is wrong. */
6484 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6485 &gfc_current_locus
);
6486 mpz_set_si (result
->value
.integer
, 1);
6490 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
6491 return simplify_cobound (coarray
, dim
, NULL
, 0);
6496 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6498 return simplify_bound (array
, dim
, kind
, 1);
6502 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6504 return simplify_cobound (array
, dim
, kind
, 1);
6509 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6511 gfc_expr
*result
, *e
;
6512 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
6514 if (!is_constant_array_expr (vector
)
6515 || !is_constant_array_expr (mask
)
6516 || (!gfc_is_constant_expr (field
)
6517 && !is_constant_array_expr (field
)))
6520 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
6522 if (vector
->ts
.type
== BT_DERIVED
)
6523 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
6524 result
->rank
= mask
->rank
;
6525 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
6527 if (vector
->ts
.type
== BT_CHARACTER
)
6528 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
6530 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
6531 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6533 = field
->expr_type
== EXPR_ARRAY
6534 ? gfc_constructor_first (field
->value
.constructor
)
6539 if (mask_ctor
->expr
->value
.logical
)
6541 gcc_assert (vector_ctor
);
6542 e
= gfc_copy_expr (vector_ctor
->expr
);
6543 vector_ctor
= gfc_constructor_next (vector_ctor
);
6545 else if (field
->expr_type
== EXPR_ARRAY
)
6546 e
= gfc_copy_expr (field_ctor
->expr
);
6548 e
= gfc_copy_expr (field
);
6550 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
6552 mask_ctor
= gfc_constructor_next (mask_ctor
);
6553 field_ctor
= gfc_constructor_next (field_ctor
);
6561 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
6565 size_t index
, len
, lenset
;
6567 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
6570 return &gfc_bad_expr
;
6572 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
6573 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
6576 if (b
!= NULL
&& b
->value
.logical
!= 0)
6581 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
6583 len
= s
->value
.character
.length
;
6584 lenset
= set
->value
.character
.length
;
6588 mpz_set_ui (result
->value
.integer
, 0);
6596 mpz_set_ui (result
->value
.integer
, 1);
6600 index
= wide_strspn (s
->value
.character
.string
,
6601 set
->value
.character
.string
) + 1;
6610 mpz_set_ui (result
->value
.integer
, len
);
6613 for (index
= len
; index
> 0; index
--)
6615 for (i
= 0; i
< lenset
; i
++)
6617 if (s
->value
.character
.string
[index
- 1]
6618 == set
->value
.character
.string
[i
])
6626 mpz_set_ui (result
->value
.integer
, index
);
6632 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
6637 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6640 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6645 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6646 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6647 return range_check (result
, "XOR");
6650 return gfc_get_logical_expr (kind
, &x
->where
,
6651 (x
->value
.logical
&& !y
->value
.logical
)
6652 || (!x
->value
.logical
&& y
->value
.logical
));
6660 /****************** Constant simplification *****************/
6662 /* Master function to convert one constant to another. While this is
6663 used as a simplification function, it requires the destination type
6664 and kind information which is supplied by a special case in
6668 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
6670 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
6685 f
= gfc_int2complex
;
6705 f
= gfc_real2complex
;
6716 f
= gfc_complex2int
;
6719 f
= gfc_complex2real
;
6722 f
= gfc_complex2complex
;
6748 f
= gfc_hollerith2int
;
6752 f
= gfc_hollerith2real
;
6756 f
= gfc_hollerith2complex
;
6760 f
= gfc_hollerith2character
;
6764 f
= gfc_hollerith2logical
;
6774 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6779 switch (e
->expr_type
)
6782 result
= f (e
, kind
);
6784 return &gfc_bad_expr
;
6788 if (!gfc_is_constant_expr (e
))
6791 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6792 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6793 result
->rank
= e
->rank
;
6795 for (c
= gfc_constructor_first (e
->value
.constructor
);
6796 c
; c
= gfc_constructor_next (c
))
6799 if (c
->iterator
== NULL
)
6800 tmp
= f (c
->expr
, kind
);
6803 g
= gfc_convert_constant (c
->expr
, type
, kind
);
6804 if (g
== &gfc_bad_expr
)
6806 gfc_free_expr (result
);
6814 gfc_free_expr (result
);
6818 gfc_constructor_append_expr (&result
->value
.constructor
,
6832 /* Function for converting character constants. */
6834 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
6839 if (!gfc_is_constant_expr (e
))
6842 if (e
->expr_type
== EXPR_CONSTANT
)
6844 /* Simple case of a scalar. */
6845 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
6847 return &gfc_bad_expr
;
6849 result
->value
.character
.length
= e
->value
.character
.length
;
6850 result
->value
.character
.string
6851 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
6852 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
6853 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
6855 /* Check we only have values representable in the destination kind. */
6856 for (i
= 0; i
< result
->value
.character
.length
; i
++)
6857 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
6860 gfc_error ("Character %qs in string at %L cannot be converted "
6861 "into character kind %d",
6862 gfc_print_wide_char (result
->value
.character
.string
[i
]),
6864 return &gfc_bad_expr
;
6869 else if (e
->expr_type
== EXPR_ARRAY
)
6871 /* For an array constructor, we convert each constructor element. */
6874 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6875 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6876 result
->rank
= e
->rank
;
6877 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
6879 for (c
= gfc_constructor_first (e
->value
.constructor
);
6880 c
; c
= gfc_constructor_next (c
))
6882 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
6883 if (tmp
== &gfc_bad_expr
)
6885 gfc_free_expr (result
);
6886 return &gfc_bad_expr
;
6891 gfc_free_expr (result
);
6895 gfc_constructor_append_expr (&result
->value
.constructor
,
6907 gfc_simplify_compiler_options (void)
6912 str
= gfc_get_option_string ();
6913 result
= gfc_get_character_expr (gfc_default_character_kind
,
6914 &gfc_current_locus
, str
, strlen (str
));
6921 gfc_simplify_compiler_version (void)
6926 len
= strlen ("GCC version ") + strlen (version_string
);
6927 buffer
= XALLOCAVEC (char, len
+ 1);
6928 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
6929 return gfc_get_character_expr (gfc_default_character_kind
,
6930 &gfc_current_locus
, buffer
, len
);
6933 /* Simplification routines for intrinsics of IEEE modules. */
6936 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
6938 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
6939 gfc_expr
*p
= arg
->expr
, *q
= arg
->next
->expr
,
6940 *rdx
= arg
->next
->next
->expr
;
6942 /* Currently, if IEEE is supported and this module is built, it means
6943 all our floating-point types conform to IEEE. Hence, we simply handle
6944 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
6945 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
6949 simplify_ieee_support (gfc_expr
*expr
)
6951 /* We consider that if the IEEE modules are loaded, we have full support
6952 for flags, halting and rounding, which are the three functions
6953 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
6954 expressions. One day, we will need libgfortran to detect support and
6955 communicate it back to us, allowing for partial support. */
6957 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
6962 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
6964 int n
= strlen(name
);
6966 if (!strncmp(sym
->name
, name
, n
))
6969 /* If a generic was used and renamed, we need more work to find out.
6970 Compare the specific name. */
6971 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
6978 gfc_simplify_ieee_functions (gfc_expr
*expr
)
6980 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
6982 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
6983 return simplify_ieee_selected_real_kind (expr
);
6984 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
6985 || matches_ieee_function_name(sym
, "ieee_support_halting")
6986 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
6987 return simplify_ieee_support (expr
);