1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2019 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
24 #include "tm.h" /* For BITS_PER_UNIT. */
27 #include "intrinsic.h"
29 #include "target-memory.h"
30 #include "constructor.h"
31 #include "version.h" /* For version_string. */
35 static int min_max_choose (gfc_expr
*, gfc_expr
*, int, bool back_val
= false);
37 gfc_expr gfc_bad_expr
;
39 static gfc_expr
*simplify_size (gfc_expr
*, gfc_expr
*, int);
42 /* Note that 'simplification' is not just transforming expressions.
43 For functions that are not simplified at compile time, range
44 checking is done if possible.
46 The return convention is that each simplification function returns:
48 A new expression node corresponding to the simplified arguments.
49 The original arguments are destroyed by the caller, and must not
50 be a part of the new expression.
52 NULL pointer indicating that no simplification was possible and
53 the original expression should remain intact.
55 An expression pointer to gfc_bad_expr (a static placeholder)
56 indicating that some error has prevented simplification. The
57 error is generated within the function and should be propagated
60 By the time a simplification function gets control, it has been
61 decided that the function call is really supposed to be the
62 intrinsic. No type checking is strictly necessary, since only
63 valid types will be passed on. On the other hand, a simplification
64 subroutine may have to look at the type of an argument as part of
67 Array arguments are only passed to these subroutines that implement
68 the simplification of transformational intrinsics.
70 The functions in this file don't have much comment with them, but
71 everything is reasonably straight-forward. The Standard, chapter 13
72 is the best comment you'll find for this file anyway. */
74 /* Range checks an expression node. If all goes well, returns the
75 node, otherwise returns &gfc_bad_expr and frees the node. */
78 range_check (gfc_expr
*result
, const char *name
)
83 if (result
->expr_type
!= EXPR_CONSTANT
)
86 switch (gfc_range_check (result
))
92 gfc_error ("Result of %s overflows its kind at %L", name
,
97 gfc_error ("Result of %s underflows its kind at %L", name
,
102 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
106 gfc_error ("Result of %s gives range error for its kind at %L", name
,
111 gfc_free_expr (result
);
112 return &gfc_bad_expr
;
116 /* A helper function that gets an optional and possibly missing
117 kind parameter. Returns the kind, -1 if something went wrong. */
120 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
127 if (k
->expr_type
!= EXPR_CONSTANT
)
129 gfc_error ("KIND parameter of %s at %L must be an initialization "
130 "expression", name
, &k
->where
);
134 if (gfc_extract_int (k
, &kind
)
135 || gfc_validate_kind (type
, kind
, true) < 0)
137 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
145 /* Converts an mpz_t signed variable into an unsigned one, assuming
146 two's complement representations and a binary width of bitsize.
147 The conversion is a no-op unless x is negative; otherwise, it can
148 be accomplished by masking out the high bits. */
151 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
157 /* Confirm that no bits above the signed range are unset if we
158 are doing range checking. */
159 if (flag_range_check
!= 0)
160 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
162 mpz_init_set_ui (mask
, 1);
163 mpz_mul_2exp (mask
, mask
, bitsize
);
164 mpz_sub_ui (mask
, mask
, 1);
166 mpz_and (x
, x
, mask
);
172 /* Confirm that no bits above the signed range are set. */
173 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
178 /* Converts an mpz_t unsigned variable into a signed one, assuming
179 two's complement representations and a binary width of bitsize.
180 If the bitsize-1 bit is set, this is taken as a sign bit and
181 the number is converted to the corresponding negative number. */
184 gfc_convert_mpz_to_signed (mpz_t x
, int bitsize
)
188 /* Confirm that no bits above the unsigned range are set if we are
189 doing range checking. */
190 if (flag_range_check
!= 0)
191 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
193 if (mpz_tstbit (x
, bitsize
- 1) == 1)
195 mpz_init_set_ui (mask
, 1);
196 mpz_mul_2exp (mask
, mask
, bitsize
);
197 mpz_sub_ui (mask
, mask
, 1);
199 /* We negate the number by hand, zeroing the high bits, that is
200 make it the corresponding positive number, and then have it
201 negated by GMP, giving the correct representation of the
204 mpz_add_ui (x
, x
, 1);
205 mpz_and (x
, x
, mask
);
214 /* In-place convert BOZ to REAL of the specified kind. */
217 convert_boz (gfc_expr
*x
, int kind
)
219 if (x
&& x
->ts
.type
== BT_INTEGER
&& x
->is_boz
)
226 if (!gfc_convert_boz (x
, &ts
))
227 return &gfc_bad_expr
;
234 /* Test that the expression is a constant array, simplifying if
235 we are dealing with a parameter array. */
238 is_constant_array_expr (gfc_expr
*e
)
245 if (e
->expr_type
== EXPR_VARIABLE
&& e
->rank
> 0
246 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
247 gfc_simplify_expr (e
, 1);
249 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
252 for (c
= gfc_constructor_first (e
->value
.constructor
);
253 c
; c
= gfc_constructor_next (c
))
254 if (c
->expr
->expr_type
!= EXPR_CONSTANT
255 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
261 /* Test for a size zero array. */
263 gfc_is_size_zero_array (gfc_expr
*array
)
266 if (array
->rank
== 0)
269 if (array
->expr_type
== EXPR_VARIABLE
&& array
->rank
> 0
270 && array
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
271 && array
->shape
!= NULL
)
273 for (int i
= 0; i
< array
->rank
; i
++)
274 if (mpz_cmp_si (array
->shape
[i
], 0) <= 0)
280 if (array
->expr_type
== EXPR_ARRAY
)
281 return array
->value
.constructor
== NULL
;
287 /* Initialize a transformational result expression with a given value. */
290 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
292 if (e
&& e
->expr_type
== EXPR_ARRAY
)
294 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
297 init_result_expr (ctor
->expr
, init
, array
);
298 ctor
= gfc_constructor_next (ctor
);
301 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
303 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
304 HOST_WIDE_INT length
;
310 e
->value
.logical
= (init
? 1 : 0);
315 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
316 else if (init
== INT_MAX
)
317 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
319 mpz_set_si (e
->value
.integer
, init
);
325 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
326 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
328 else if (init
== INT_MAX
)
329 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
331 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
335 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
341 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
342 gfc_extract_hwi (len
, &length
);
343 string
= gfc_get_wide_string (length
+ 1);
344 gfc_wide_memset (string
, 0, length
);
346 else if (init
== INT_MAX
)
348 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
349 gfc_extract_hwi (len
, &length
);
350 string
= gfc_get_wide_string (length
+ 1);
351 gfc_wide_memset (string
, 255, length
);
356 string
= gfc_get_wide_string (1);
359 string
[length
] = '\0';
360 e
->value
.character
.length
= length
;
361 e
->value
.character
.string
= string
;
373 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
374 if conj_a is true, the matrix_a is complex conjugated. */
377 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
378 gfc_expr
*matrix_b
, int stride_b
, int offset_b
,
381 gfc_expr
*result
, *a
, *b
, *c
;
383 /* Set result to an INTEGER(1) 0 for numeric types and .false. for
384 LOGICAL. Mixed-mode math in the loop will promote result to the
385 correct type and kind. */
386 if (matrix_a
->ts
.type
== BT_LOGICAL
)
387 result
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, false);
389 result
= gfc_get_int_expr (1, NULL
, 0);
390 result
->where
= matrix_a
->where
;
392 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
393 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
396 /* Copying of expressions is required as operands are free'd
397 by the gfc_arith routines. */
398 switch (result
->ts
.type
)
401 result
= gfc_or (result
,
402 gfc_and (gfc_copy_expr (a
),
409 if (conj_a
&& a
->ts
.type
== BT_COMPLEX
)
410 c
= gfc_simplify_conjg (a
);
412 c
= gfc_copy_expr (a
);
413 result
= gfc_add (result
, gfc_multiply (c
, gfc_copy_expr (b
)));
420 offset_a
+= stride_a
;
421 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
423 offset_b
+= stride_b
;
424 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
431 /* Build a result expression for transformational intrinsics,
435 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
436 int kind
, locus
* where
)
441 if (!dim
|| array
->rank
== 1)
442 return gfc_get_constant_expr (type
, kind
, where
);
444 result
= gfc_get_array_expr (type
, kind
, where
);
445 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
446 result
->rank
= array
->rank
- 1;
448 /* gfc_array_size() would count the number of elements in the constructor,
449 we have not built those yet. */
451 for (i
= 0; i
< result
->rank
; ++i
)
452 nelem
*= mpz_get_ui (result
->shape
[i
]);
454 for (i
= 0; i
< nelem
; ++i
)
456 gfc_constructor_append_expr (&result
->value
.constructor
,
457 gfc_get_constant_expr (type
, kind
, where
),
465 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
467 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
468 of COUNT intrinsic is .TRUE..
470 Interface and implementation mimics arith functions as
471 gfc_add, gfc_multiply, etc. */
474 gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
478 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
479 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
480 gcc_assert (op2
->value
.logical
);
482 result
= gfc_copy_expr (op1
);
483 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
491 /* Transforms an ARRAY with operation OP, according to MASK, to a
492 scalar RESULT. E.g. called if
494 REAL, PARAMETER :: array(n, m) = ...
495 REAL, PARAMETER :: s = SUM(array)
497 where OP == gfc_add(). */
500 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
501 transformational_op op
)
504 gfc_constructor
*array_ctor
, *mask_ctor
;
506 /* Shortcut for constant .FALSE. MASK. */
508 && mask
->expr_type
== EXPR_CONSTANT
509 && !mask
->value
.logical
)
512 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
514 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
515 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
519 a
= array_ctor
->expr
;
520 array_ctor
= gfc_constructor_next (array_ctor
);
522 /* A constant MASK equals .TRUE. here and can be ignored. */
526 mask_ctor
= gfc_constructor_next (mask_ctor
);
527 if (!m
->value
.logical
)
531 result
= op (result
, gfc_copy_expr (a
));
539 /* Transforms an ARRAY with operation OP, according to MASK, to an
540 array RESULT. E.g. called if
542 REAL, PARAMETER :: array(n, m) = ...
543 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
545 where OP == gfc_multiply().
546 The result might be post processed using post_op. */
549 simplify_transformation_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*dim
,
550 gfc_expr
*mask
, transformational_op op
,
551 transformational_op post_op
)
554 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
555 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
556 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
558 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
559 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
560 tmpstride
[GFC_MAX_DIMENSIONS
];
562 /* Shortcut for constant .FALSE. MASK. */
564 && mask
->expr_type
== EXPR_CONSTANT
565 && !mask
->value
.logical
)
568 /* Build an indexed table for array element expressions to minimize
569 linked-list traversal. Masked elements are set to NULL. */
570 gfc_array_size (array
, &size
);
571 arraysize
= mpz_get_ui (size
);
574 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
576 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
578 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
579 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
581 for (i
= 0; i
< arraysize
; ++i
)
583 arrayvec
[i
] = array_ctor
->expr
;
584 array_ctor
= gfc_constructor_next (array_ctor
);
588 if (!mask_ctor
->expr
->value
.logical
)
591 mask_ctor
= gfc_constructor_next (mask_ctor
);
595 /* Same for the result expression. */
596 gfc_array_size (result
, &size
);
597 resultsize
= mpz_get_ui (size
);
600 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
601 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
602 for (i
= 0; i
< resultsize
; ++i
)
604 resultvec
[i
] = result_ctor
->expr
;
605 result_ctor
= gfc_constructor_next (result_ctor
);
608 gfc_extract_int (dim
, &dim_index
);
609 dim_index
-= 1; /* zero-base index */
613 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
616 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
619 dim_extent
= mpz_get_si (array
->shape
[i
]);
620 dim_stride
= tmpstride
[i
];
624 extent
[n
] = mpz_get_si (array
->shape
[i
]);
625 sstride
[n
] = tmpstride
[i
];
626 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
630 done
= resultsize
<= 0;
635 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
637 *dest
= op (*dest
, gfc_copy_expr (*src
));
644 while (!done
&& count
[n
] == extent
[n
])
647 base
-= sstride
[n
] * extent
[n
];
648 dest
-= dstride
[n
] * extent
[n
];
651 if (n
< result
->rank
)
653 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
654 times, we'd warn for the last iteration, because the
655 array index will have already been incremented to the
656 array sizes, and we can't tell that this must make
657 the test against result->rank false, because ranks
658 must not exceed GFC_MAX_DIMENSIONS. */
659 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
670 /* Place updated expression in result constructor. */
671 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
672 for (i
= 0; i
< resultsize
; ++i
)
675 result_ctor
->expr
= post_op (result_ctor
->expr
, resultvec
[i
]);
677 result_ctor
->expr
= resultvec
[i
];
678 result_ctor
= gfc_constructor_next (result_ctor
);
688 simplify_transformation (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
689 int init_val
, transformational_op op
)
694 size_zero
= gfc_is_size_zero_array (array
);
696 if (!(is_constant_array_expr (array
) || size_zero
)
697 || !gfc_is_constant_expr (dim
))
701 && !is_constant_array_expr (mask
)
702 && mask
->expr_type
!= EXPR_CONSTANT
)
705 result
= transformational_result (array
, dim
, array
->ts
.type
,
706 array
->ts
.kind
, &array
->where
);
707 init_result_expr (result
, init_val
, array
);
712 return !dim
|| array
->rank
== 1 ?
713 simplify_transformation_to_scalar (result
, array
, mask
, op
) :
714 simplify_transformation_to_array (result
, array
, dim
, mask
, op
, NULL
);
718 /********************** Simplification functions *****************************/
721 gfc_simplify_abs (gfc_expr
*e
)
725 if (e
->expr_type
!= EXPR_CONSTANT
)
731 result
= gfc_get_constant_expr (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
732 mpz_abs (result
->value
.integer
, e
->value
.integer
);
733 return range_check (result
, "IABS");
736 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
737 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
738 return range_check (result
, "ABS");
741 gfc_set_model_kind (e
->ts
.kind
);
742 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
743 mpc_abs (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
744 return range_check (result
, "CABS");
747 gfc_internal_error ("gfc_simplify_abs(): Bad type");
753 simplify_achar_char (gfc_expr
*e
, gfc_expr
*k
, const char *name
, bool ascii
)
757 bool too_large
= false;
759 if (e
->expr_type
!= EXPR_CONSTANT
)
762 kind
= get_kind (BT_CHARACTER
, k
, name
, gfc_default_character_kind
);
764 return &gfc_bad_expr
;
766 if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
768 gfc_error ("Argument of %s function at %L is negative", name
,
770 return &gfc_bad_expr
;
773 if (ascii
&& warn_surprising
&& mpz_cmp_si (e
->value
.integer
, 127) > 0)
774 gfc_warning (OPT_Wsurprising
,
775 "Argument of %s function at %L outside of range [0,127]",
778 if (kind
== 1 && mpz_cmp_si (e
->value
.integer
, 255) > 0)
783 mpz_init_set_ui (t
, 2);
784 mpz_pow_ui (t
, t
, 32);
785 mpz_sub_ui (t
, t
, 1);
786 if (mpz_cmp (e
->value
.integer
, t
) > 0)
793 gfc_error ("Argument of %s function at %L is too large for the "
794 "collating sequence of kind %d", name
, &e
->where
, kind
);
795 return &gfc_bad_expr
;
798 result
= gfc_get_character_expr (kind
, &e
->where
, NULL
, 1);
799 result
->value
.character
.string
[0] = mpz_get_ui (e
->value
.integer
);
806 /* We use the processor's collating sequence, because all
807 systems that gfortran currently works on are ASCII. */
810 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
812 return simplify_achar_char (e
, k
, "ACHAR", true);
817 gfc_simplify_acos (gfc_expr
*x
)
821 if (x
->expr_type
!= EXPR_CONSTANT
)
827 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
828 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
830 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
832 return &gfc_bad_expr
;
834 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
835 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
839 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
840 mpc_acos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
844 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
847 return range_check (result
, "ACOS");
851 gfc_simplify_acosh (gfc_expr
*x
)
855 if (x
->expr_type
!= EXPR_CONSTANT
)
861 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
863 gfc_error ("Argument of ACOSH at %L must not be less than 1",
865 return &gfc_bad_expr
;
868 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
869 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
873 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
874 mpc_acosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
878 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
881 return range_check (result
, "ACOSH");
885 gfc_simplify_adjustl (gfc_expr
*e
)
891 if (e
->expr_type
!= EXPR_CONSTANT
)
894 len
= e
->value
.character
.length
;
896 for (count
= 0, i
= 0; i
< len
; ++i
)
898 ch
= e
->value
.character
.string
[i
];
904 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
905 for (i
= 0; i
< len
- count
; ++i
)
906 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
913 gfc_simplify_adjustr (gfc_expr
*e
)
919 if (e
->expr_type
!= EXPR_CONSTANT
)
922 len
= e
->value
.character
.length
;
924 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
926 ch
= e
->value
.character
.string
[i
];
932 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
933 for (i
= 0; i
< count
; ++i
)
934 result
->value
.character
.string
[i
] = ' ';
936 for (i
= count
; i
< len
; ++i
)
937 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
944 gfc_simplify_aimag (gfc_expr
*e
)
948 if (e
->expr_type
!= EXPR_CONSTANT
)
951 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
952 mpfr_set (result
->value
.real
, mpc_imagref (e
->value
.complex), GFC_RND_MODE
);
954 return range_check (result
, "AIMAG");
959 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
961 gfc_expr
*rtrunc
, *result
;
964 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
966 return &gfc_bad_expr
;
968 if (e
->expr_type
!= EXPR_CONSTANT
)
971 rtrunc
= gfc_copy_expr (e
);
972 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
974 result
= gfc_real2real (rtrunc
, kind
);
976 gfc_free_expr (rtrunc
);
978 return range_check (result
, "AINT");
983 gfc_simplify_all (gfc_expr
*mask
, gfc_expr
*dim
)
985 return simplify_transformation (mask
, dim
, NULL
, true, gfc_and
);
990 gfc_simplify_dint (gfc_expr
*e
)
992 gfc_expr
*rtrunc
, *result
;
994 if (e
->expr_type
!= EXPR_CONSTANT
)
997 rtrunc
= gfc_copy_expr (e
);
998 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
1000 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
1002 gfc_free_expr (rtrunc
);
1004 return range_check (result
, "DINT");
1009 gfc_simplify_dreal (gfc_expr
*e
)
1011 gfc_expr
*result
= NULL
;
1013 if (e
->expr_type
!= EXPR_CONSTANT
)
1016 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
1017 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
1019 return range_check (result
, "DREAL");
1024 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
1029 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
1031 return &gfc_bad_expr
;
1033 if (e
->expr_type
!= EXPR_CONSTANT
)
1036 result
= gfc_get_constant_expr (e
->ts
.type
, kind
, &e
->where
);
1037 mpfr_round (result
->value
.real
, e
->value
.real
);
1039 return range_check (result
, "ANINT");
1044 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
1049 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1052 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1057 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
1058 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1059 return range_check (result
, "AND");
1062 return gfc_get_logical_expr (kind
, &x
->where
,
1063 x
->value
.logical
&& y
->value
.logical
);
1072 gfc_simplify_any (gfc_expr
*mask
, gfc_expr
*dim
)
1074 return simplify_transformation (mask
, dim
, NULL
, false, gfc_or
);
1079 gfc_simplify_dnint (gfc_expr
*e
)
1083 if (e
->expr_type
!= EXPR_CONSTANT
)
1086 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &e
->where
);
1087 mpfr_round (result
->value
.real
, e
->value
.real
);
1089 return range_check (result
, "DNINT");
1094 gfc_simplify_asin (gfc_expr
*x
)
1098 if (x
->expr_type
!= EXPR_CONSTANT
)
1104 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1105 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1107 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1109 return &gfc_bad_expr
;
1111 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1112 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1116 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1117 mpc_asin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1121 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1124 return range_check (result
, "ASIN");
1129 gfc_simplify_asinh (gfc_expr
*x
)
1133 if (x
->expr_type
!= EXPR_CONSTANT
)
1136 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1141 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1145 mpc_asinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1149 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1152 return range_check (result
, "ASINH");
1157 gfc_simplify_atan (gfc_expr
*x
)
1161 if (x
->expr_type
!= EXPR_CONSTANT
)
1164 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1169 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1173 mpc_atan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1177 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1180 return range_check (result
, "ATAN");
1185 gfc_simplify_atanh (gfc_expr
*x
)
1189 if (x
->expr_type
!= EXPR_CONSTANT
)
1195 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
1196 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
1198 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1200 return &gfc_bad_expr
;
1202 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1203 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1207 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1208 mpc_atanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1212 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1215 return range_check (result
, "ATANH");
1220 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1224 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1227 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1229 gfc_error ("If first argument of ATAN2 %L is zero, then the "
1230 "second argument must not be zero", &x
->where
);
1231 return &gfc_bad_expr
;
1234 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1235 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1237 return range_check (result
, "ATAN2");
1242 gfc_simplify_bessel_j0 (gfc_expr
*x
)
1246 if (x
->expr_type
!= EXPR_CONSTANT
)
1249 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1250 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1252 return range_check (result
, "BESSEL_J0");
1257 gfc_simplify_bessel_j1 (gfc_expr
*x
)
1261 if (x
->expr_type
!= EXPR_CONSTANT
)
1264 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1265 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1267 return range_check (result
, "BESSEL_J1");
1272 gfc_simplify_bessel_jn (gfc_expr
*order
, gfc_expr
*x
)
1277 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1280 n
= mpz_get_si (order
->value
.integer
);
1281 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1282 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1284 return range_check (result
, "BESSEL_JN");
1288 /* Simplify transformational form of JN and YN. */
1291 gfc_simplify_bessel_n2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
,
1298 mpfr_t x2rev
, last1
, last2
;
1300 if (x
->expr_type
!= EXPR_CONSTANT
|| order1
->expr_type
!= EXPR_CONSTANT
1301 || order2
->expr_type
!= EXPR_CONSTANT
)
1304 n1
= mpz_get_si (order1
->value
.integer
);
1305 n2
= mpz_get_si (order2
->value
.integer
);
1306 result
= gfc_get_array_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1308 result
->shape
= gfc_get_shape (1);
1309 mpz_init_set_ui (result
->shape
[0], MAX (n2
-n1
+1, 0));
1314 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1315 YN(N, 0.0) = -Inf. */
1317 if (mpfr_cmp_ui (x
->value
.real
, 0.0) == 0)
1319 if (!jn
&& flag_range_check
)
1321 gfc_error ("Result of BESSEL_YN is -INF at %L", &result
->where
);
1322 gfc_free_expr (result
);
1323 return &gfc_bad_expr
;
1328 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1329 mpfr_set_ui (e
->value
.real
, 1, GFC_RND_MODE
);
1330 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1335 for (i
= n1
; i
<= n2
; i
++)
1337 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1339 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
1341 mpfr_set_inf (e
->value
.real
, -1);
1342 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1349 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1350 are stable for downward recursion and Neumann functions are stable
1351 for upward recursion. It is
1353 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1354 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1355 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1357 gfc_set_model_kind (x
->ts
.kind
);
1359 /* Get first recursion anchor. */
1363 mpfr_jn (last1
, n2
, x
->value
.real
, GFC_RND_MODE
);
1365 mpfr_yn (last1
, n1
, x
->value
.real
, GFC_RND_MODE
);
1367 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1368 mpfr_set (e
->value
.real
, last1
, GFC_RND_MODE
);
1369 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1373 gfc_free_expr (result
);
1374 return &gfc_bad_expr
;
1376 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1384 /* Get second recursion anchor. */
1388 mpfr_jn (last2
, n2
-1, x
->value
.real
, GFC_RND_MODE
);
1390 mpfr_yn (last2
, n1
+1, x
->value
.real
, GFC_RND_MODE
);
1392 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1393 mpfr_set (e
->value
.real
, last2
, GFC_RND_MODE
);
1394 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1399 gfc_free_expr (result
);
1400 return &gfc_bad_expr
;
1403 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
, -2);
1405 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1414 /* Start actual recursion. */
1417 mpfr_ui_div (x2rev
, 2, x
->value
.real
, GFC_RND_MODE
);
1419 for (i
= 2; i
<= n2
-n1
; i
++)
1421 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1423 /* Special case: For YN, if the previous N gave -INF, set
1424 also N+1 to -INF. */
1425 if (!jn
&& !flag_range_check
&& mpfr_inf_p (last2
))
1427 mpfr_set_inf (e
->value
.real
, -1);
1428 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1433 mpfr_mul_si (e
->value
.real
, x2rev
, jn
? (n2
-i
+1) : (n1
+i
-1),
1435 mpfr_mul (e
->value
.real
, e
->value
.real
, last2
, GFC_RND_MODE
);
1436 mpfr_sub (e
->value
.real
, e
->value
.real
, last1
, GFC_RND_MODE
);
1438 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1440 /* Range_check frees "e" in that case. */
1446 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
,
1449 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1451 mpfr_set (last1
, last2
, GFC_RND_MODE
);
1452 mpfr_set (last2
, e
->value
.real
, GFC_RND_MODE
);
1465 gfc_free_expr (result
);
1466 return &gfc_bad_expr
;
1471 gfc_simplify_bessel_jn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1473 return gfc_simplify_bessel_n2 (order1
, order2
, x
, true);
1478 gfc_simplify_bessel_y0 (gfc_expr
*x
)
1482 if (x
->expr_type
!= EXPR_CONSTANT
)
1485 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1486 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1488 return range_check (result
, "BESSEL_Y0");
1493 gfc_simplify_bessel_y1 (gfc_expr
*x
)
1497 if (x
->expr_type
!= EXPR_CONSTANT
)
1500 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1501 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1503 return range_check (result
, "BESSEL_Y1");
1508 gfc_simplify_bessel_yn (gfc_expr
*order
, gfc_expr
*x
)
1513 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1516 n
= mpz_get_si (order
->value
.integer
);
1517 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1518 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1520 return range_check (result
, "BESSEL_YN");
1525 gfc_simplify_bessel_yn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1527 return gfc_simplify_bessel_n2 (order1
, order2
, x
, false);
1532 gfc_simplify_bit_size (gfc_expr
*e
)
1534 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1535 return gfc_get_int_expr (e
->ts
.kind
, &e
->where
,
1536 gfc_integer_kinds
[i
].bit_size
);
1541 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
1545 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
1548 if (gfc_extract_int (bit
, &b
) || b
< 0)
1549 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
, false);
1551 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
,
1552 mpz_tstbit (e
->value
.integer
, b
));
1557 compare_bitwise (gfc_expr
*i
, gfc_expr
*j
)
1562 gcc_assert (i
->ts
.type
== BT_INTEGER
);
1563 gcc_assert (j
->ts
.type
== BT_INTEGER
);
1565 mpz_init_set (x
, i
->value
.integer
);
1566 k
= gfc_validate_kind (i
->ts
.type
, i
->ts
.kind
, false);
1567 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
1569 mpz_init_set (y
, j
->value
.integer
);
1570 k
= gfc_validate_kind (j
->ts
.type
, j
->ts
.kind
, false);
1571 convert_mpz_to_unsigned (y
, gfc_integer_kinds
[k
].bit_size
);
1573 res
= mpz_cmp (x
, y
);
1581 gfc_simplify_bge (gfc_expr
*i
, gfc_expr
*j
)
1583 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1586 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1587 compare_bitwise (i
, j
) >= 0);
1592 gfc_simplify_bgt (gfc_expr
*i
, gfc_expr
*j
)
1594 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1597 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1598 compare_bitwise (i
, j
) > 0);
1603 gfc_simplify_ble (gfc_expr
*i
, gfc_expr
*j
)
1605 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1608 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1609 compare_bitwise (i
, j
) <= 0);
1614 gfc_simplify_blt (gfc_expr
*i
, gfc_expr
*j
)
1616 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1619 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1620 compare_bitwise (i
, j
) < 0);
1625 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
1627 gfc_expr
*ceil
, *result
;
1630 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
1632 return &gfc_bad_expr
;
1634 if (e
->expr_type
!= EXPR_CONSTANT
)
1637 ceil
= gfc_copy_expr (e
);
1638 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
1640 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
1641 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
, &e
->where
);
1643 gfc_free_expr (ceil
);
1645 return range_check (result
, "CEILING");
1650 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
1652 return simplify_achar_char (e
, k
, "CHAR", false);
1656 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1659 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
1663 if (convert_boz (x
, kind
) == &gfc_bad_expr
)
1664 return &gfc_bad_expr
;
1666 if (convert_boz (y
, kind
) == &gfc_bad_expr
)
1667 return &gfc_bad_expr
;
1669 if (x
->expr_type
!= EXPR_CONSTANT
1670 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1673 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &x
->where
);
1678 mpc_set_z (result
->value
.complex, x
->value
.integer
, GFC_MPC_RND_MODE
);
1682 mpc_set_fr (result
->value
.complex, x
->value
.real
, GFC_RND_MODE
);
1686 mpc_set (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1690 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1694 return range_check (result
, name
);
1699 mpfr_set_z (mpc_imagref (result
->value
.complex),
1700 y
->value
.integer
, GFC_RND_MODE
);
1704 mpfr_set (mpc_imagref (result
->value
.complex),
1705 y
->value
.real
, GFC_RND_MODE
);
1709 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1712 return range_check (result
, name
);
1717 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
1721 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_complex_kind
);
1723 return &gfc_bad_expr
;
1725 return simplify_cmplx ("CMPLX", x
, y
, kind
);
1730 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
1734 if (x
->ts
.type
== BT_INTEGER
&& y
->ts
.type
== BT_INTEGER
)
1735 kind
= gfc_default_complex_kind
;
1736 else if (x
->ts
.type
== BT_REAL
|| y
->ts
.type
== BT_INTEGER
)
1738 else if (x
->ts
.type
== BT_INTEGER
|| y
->ts
.type
== BT_REAL
)
1740 else if (x
->ts
.type
== BT_REAL
&& y
->ts
.type
== BT_REAL
)
1741 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
1745 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1750 gfc_simplify_conjg (gfc_expr
*e
)
1754 if (e
->expr_type
!= EXPR_CONSTANT
)
1757 result
= gfc_copy_expr (e
);
1758 mpc_conj (result
->value
.complex, result
->value
.complex, GFC_MPC_RND_MODE
);
1760 return range_check (result
, "CONJG");
1763 /* Return the simplification of the constant expression in icall, or NULL
1764 if the expression is not constant. */
1767 simplify_trig_call (gfc_expr
*icall
)
1769 gfc_isym_id func
= icall
->value
.function
.isym
->id
;
1770 gfc_expr
*x
= icall
->value
.function
.actual
->expr
;
1772 /* The actual simplifiers will return NULL for non-constant x. */
1776 return gfc_simplify_acos (x
);
1778 return gfc_simplify_asin (x
);
1780 return gfc_simplify_atan (x
);
1782 return gfc_simplify_cos (x
);
1783 case GFC_ISYM_COTAN
:
1784 return gfc_simplify_cotan (x
);
1786 return gfc_simplify_sin (x
);
1788 return gfc_simplify_tan (x
);
1790 gfc_internal_error ("in simplify_trig_call(): Bad intrinsic");
1794 /* Convert a floating-point number from radians to degrees. */
1797 degrees_f (mpfr_t x
, mp_rnd_t rnd_mode
)
1802 /* Set x = x % 2pi to avoid offsets with large angles. */
1803 mpfr_const_pi (tmp
, rnd_mode
);
1804 mpfr_mul_ui (tmp
, tmp
, 2, rnd_mode
);
1805 mpfr_fmod (tmp
, x
, tmp
, rnd_mode
);
1807 /* Set x = x * 180. */
1808 mpfr_mul_ui (x
, x
, 180, rnd_mode
);
1810 /* Set x = x / pi. */
1811 mpfr_const_pi (tmp
, rnd_mode
);
1812 mpfr_div (x
, x
, tmp
, rnd_mode
);
1817 /* Convert a floating-point number from degrees to radians. */
1820 radians_f (mpfr_t x
, mp_rnd_t rnd_mode
)
1825 /* Set x = x % 360 to avoid offsets with large angles. */
1826 mpfr_set_ui (tmp
, 360, rnd_mode
);
1827 mpfr_fmod (tmp
, x
, tmp
, rnd_mode
);
1829 /* Set x = x * pi. */
1830 mpfr_const_pi (tmp
, rnd_mode
);
1831 mpfr_mul (x
, x
, tmp
, rnd_mode
);
1833 /* Set x = x / 180. */
1834 mpfr_div_ui (x
, x
, 180, rnd_mode
);
1840 /* Convert argument to radians before calling a trig function. */
1843 gfc_simplify_trigd (gfc_expr
*icall
)
1847 arg
= icall
->value
.function
.actual
->expr
;
1849 if (arg
->ts
.type
!= BT_REAL
)
1850 gfc_internal_error ("in gfc_simplify_trigd(): Bad type");
1852 if (arg
->expr_type
== EXPR_CONSTANT
)
1853 /* Convert constant to radians before passing off to simplifier. */
1854 radians_f (arg
->value
.real
, GFC_RND_MODE
);
1856 /* Let the usual simplifier take over - we just simplified the arg. */
1857 return simplify_trig_call (icall
);
1860 /* Convert result of an inverse trig function to degrees. */
1863 gfc_simplify_atrigd (gfc_expr
*icall
)
1867 if (icall
->value
.function
.actual
->expr
->ts
.type
!= BT_REAL
)
1868 gfc_internal_error ("in gfc_simplify_atrigd(): Bad type");
1870 /* See if another simplifier has work to do first. */
1871 result
= simplify_trig_call (icall
);
1873 if (result
&& result
->expr_type
== EXPR_CONSTANT
)
1875 /* Convert constant to degrees after passing off to actual simplifier. */
1876 degrees_f (result
->value
.real
, GFC_RND_MODE
);
1880 /* Let gfc_resolve_atrigd take care of the non-constant case. */
1884 /* Convert the result of atan2 to degrees. */
1887 gfc_simplify_atan2d (gfc_expr
*y
, gfc_expr
*x
)
1891 if (x
->ts
.type
!= BT_REAL
|| y
->ts
.type
!= BT_REAL
)
1892 gfc_internal_error ("in gfc_simplify_atan2d(): Bad type");
1894 if (x
->expr_type
== EXPR_CONSTANT
&& y
->expr_type
== EXPR_CONSTANT
)
1896 result
= gfc_simplify_atan2 (y
, x
);
1899 degrees_f (result
->value
.real
, GFC_RND_MODE
);
1904 /* Let gfc_resolve_atan2d take care of the non-constant case. */
1909 gfc_simplify_cos (gfc_expr
*x
)
1913 if (x
->expr_type
!= EXPR_CONSTANT
)
1916 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1921 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1925 gfc_set_model_kind (x
->ts
.kind
);
1926 mpc_cos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1930 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1933 return range_check (result
, "COS");
1938 gfc_simplify_cosh (gfc_expr
*x
)
1942 if (x
->expr_type
!= EXPR_CONSTANT
)
1945 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1950 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1954 mpc_cosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1961 return range_check (result
, "COSH");
1966 gfc_simplify_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1971 size_zero
= gfc_is_size_zero_array (mask
);
1973 if (!(is_constant_array_expr (mask
) || size_zero
)
1974 || !gfc_is_constant_expr (dim
)
1975 || !gfc_is_constant_expr (kind
))
1978 result
= transformational_result (mask
, dim
,
1980 get_kind (BT_INTEGER
, kind
, "COUNT",
1981 gfc_default_integer_kind
),
1984 init_result_expr (result
, 0, NULL
);
1989 /* Passing MASK twice, once as data array, once as mask.
1990 Whenever gfc_count is called, '1' is added to the result. */
1991 return !dim
|| mask
->rank
== 1 ?
1992 simplify_transformation_to_scalar (result
, mask
, mask
, gfc_count
) :
1993 simplify_transformation_to_array (result
, mask
, dim
, mask
, gfc_count
, NULL
);
1996 /* Simplification routine for cshift. This works by copying the array
1997 expressions into a one-dimensional array, shuffling the values into another
1998 one-dimensional array and creating the new array expression from this. The
1999 shuffling part is basically taken from the library routine. */
2002 gfc_simplify_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
2006 gfc_expr
**arrayvec
, **resultvec
;
2007 gfc_expr
**rptr
, **sptr
;
2009 size_t arraysize
, shiftsize
, i
;
2010 gfc_constructor
*array_ctor
, *shift_ctor
;
2011 ssize_t
*shiftvec
, *hptr
;
2012 ssize_t shift_val
, len
;
2013 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
2014 hs_ex
[GFC_MAX_DIMENSIONS
+ 1],
2015 hstride
[GFC_MAX_DIMENSIONS
], sstride
[GFC_MAX_DIMENSIONS
],
2016 a_extent
[GFC_MAX_DIMENSIONS
], a_stride
[GFC_MAX_DIMENSIONS
],
2017 h_extent
[GFC_MAX_DIMENSIONS
],
2018 ss_ex
[GFC_MAX_DIMENSIONS
+ 1];
2022 gfc_expr
**src
, **dest
;
2024 if (!is_constant_array_expr (array
))
2027 if (shift
->rank
> 0)
2028 gfc_simplify_expr (shift
, 1);
2030 if (!gfc_is_constant_expr (shift
))
2033 /* Make dim zero-based. */
2036 if (!gfc_is_constant_expr (dim
))
2038 which
= mpz_get_si (dim
->value
.integer
) - 1;
2043 gfc_array_size (array
, &size
);
2044 arraysize
= mpz_get_ui (size
);
2047 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
2048 result
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
2049 result
->rank
= array
->rank
;
2050 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
2055 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2056 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
2057 for (i
= 0; i
< arraysize
; i
++)
2059 arrayvec
[i
] = array_ctor
->expr
;
2060 array_ctor
= gfc_constructor_next (array_ctor
);
2063 resultvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2068 for (d
=0; d
< array
->rank
; d
++)
2070 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2071 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2074 if (shift
->rank
> 0)
2076 gfc_array_size (shift
, &size
);
2077 shiftsize
= mpz_get_ui (size
);
2079 shiftvec
= XCNEWVEC (ssize_t
, shiftsize
);
2080 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2081 for (d
= 0; d
< shift
->rank
; d
++)
2083 h_extent
[d
] = mpz_get_si (shift
->shape
[d
]);
2084 hstride
[d
] = d
== 0 ? 1 : hstride
[d
-1] * h_extent
[d
-1];
2090 /* Shut up compiler */
2095 for (d
=0; d
< array
->rank
; d
++)
2099 rsoffset
= a_stride
[d
];
2105 extent
[n
] = a_extent
[d
];
2106 sstride
[n
] = a_stride
[d
];
2107 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2109 hs_ex
[n
] = hstride
[n
] * extent
[n
];
2118 for (i
= 0; i
< shiftsize
; i
++)
2121 val
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2126 shift_ctor
= gfc_constructor_next (shift_ctor
);
2132 shift_val
= mpz_get_si (shift
->value
.integer
);
2133 shift_val
= shift_val
% len
;
2138 continue_loop
= true;
2144 while (continue_loop
)
2152 src
= &sptr
[sh
* rsoffset
];
2154 for (n
= 0; n
< len
- sh
; n
++)
2161 for ( n
= 0; n
< sh
; n
++)
2173 while (count
[n
] == extent
[n
])
2183 continue_loop
= false;
2197 for (i
= 0; i
< arraysize
; i
++)
2199 gfc_constructor_append_expr (&result
->value
.constructor
,
2200 gfc_copy_expr (resultvec
[i
]),
2208 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2210 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
2215 gfc_simplify_dble (gfc_expr
*e
)
2217 gfc_expr
*result
= NULL
;
2219 if (e
->expr_type
!= EXPR_CONSTANT
)
2222 if (convert_boz (e
, gfc_default_double_kind
) == &gfc_bad_expr
)
2223 return &gfc_bad_expr
;
2225 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
2226 if (result
== &gfc_bad_expr
)
2227 return &gfc_bad_expr
;
2229 return range_check (result
, "DBLE");
2234 gfc_simplify_digits (gfc_expr
*x
)
2238 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2243 digits
= gfc_integer_kinds
[i
].digits
;
2248 digits
= gfc_real_kinds
[i
].digits
;
2255 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
2260 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
2265 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2268 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2269 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
2274 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
2275 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2277 mpz_set_ui (result
->value
.integer
, 0);
2282 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
2283 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
2286 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2291 gfc_internal_error ("gfc_simplify_dim(): Bad type");
2294 return range_check (result
, "DIM");
2299 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2301 /* If vector_a is a zero-sized array, the result is 0 for INTEGER,
2302 REAL, and COMPLEX types and .false. for LOGICAL. */
2303 if (vector_a
->shape
&& mpz_get_si (vector_a
->shape
[0]) == 0)
2305 if (vector_a
->ts
.type
== BT_LOGICAL
)
2306 return gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, false);
2308 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
2311 if (!is_constant_array_expr (vector_a
)
2312 || !is_constant_array_expr (vector_b
))
2315 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
2320 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
2322 gfc_expr
*a1
, *a2
, *result
;
2324 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2327 a1
= gfc_real2real (x
, gfc_default_double_kind
);
2328 a2
= gfc_real2real (y
, gfc_default_double_kind
);
2330 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
2331 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
2336 return range_check (result
, "DPROD");
2341 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
2345 int i
, k
, size
, shift
;
2347 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
2348 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
2351 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
2352 size
= gfc_integer_kinds
[k
].bit_size
;
2354 gfc_extract_int (shiftarg
, &shift
);
2356 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2358 shift
= size
- shift
;
2360 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
2361 mpz_set_ui (result
->value
.integer
, 0);
2363 for (i
= 0; i
< shift
; i
++)
2364 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
2365 mpz_setbit (result
->value
.integer
, i
);
2367 for (i
= 0; i
< size
- shift
; i
++)
2368 if (mpz_tstbit (arg1
->value
.integer
, i
))
2369 mpz_setbit (result
->value
.integer
, shift
+ i
);
2371 /* Convert to a signed value. */
2372 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
2379 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2381 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
2386 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2388 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
2393 gfc_simplify_eoshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*boundary
,
2400 gfc_expr
**arrayvec
, **resultvec
;
2401 gfc_expr
**rptr
, **sptr
;
2403 size_t arraysize
, i
;
2404 gfc_constructor
*array_ctor
, *shift_ctor
, *bnd_ctor
;
2405 ssize_t shift_val
, len
;
2406 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
2407 sstride
[GFC_MAX_DIMENSIONS
], a_extent
[GFC_MAX_DIMENSIONS
],
2408 a_stride
[GFC_MAX_DIMENSIONS
], ss_ex
[GFC_MAX_DIMENSIONS
+ 1];
2412 gfc_expr
**src
, **dest
;
2415 if (!is_constant_array_expr (array
))
2418 if (shift
->rank
> 0)
2419 gfc_simplify_expr (shift
, 1);
2421 if (!gfc_is_constant_expr (shift
))
2426 if (boundary
->rank
> 0)
2427 gfc_simplify_expr (boundary
, 1);
2429 if (!gfc_is_constant_expr (boundary
))
2435 if (!gfc_is_constant_expr (dim
))
2437 which
= mpz_get_si (dim
->value
.integer
) - 1;
2443 if (boundary
== NULL
)
2445 temp_boundary
= true;
2446 switch (array
->ts
.type
)
2450 bnd
= gfc_get_int_expr (array
->ts
.kind
, NULL
, 0);
2454 bnd
= gfc_get_logical_expr (array
->ts
.kind
, NULL
, 0);
2458 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2459 mpfr_set_ui (bnd
->value
.real
, 0, GFC_RND_MODE
);
2463 bnd
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &gfc_current_locus
);
2464 mpc_set_ui (bnd
->value
.complex, 0, GFC_RND_MODE
);
2468 s_len
= mpz_get_ui (array
->ts
.u
.cl
->length
->value
.integer
);
2469 bnd
= gfc_get_character_expr (array
->ts
.kind
, &gfc_current_locus
, NULL
, s_len
);
2479 temp_boundary
= false;
2483 gfc_array_size (array
, &size
);
2484 arraysize
= mpz_get_ui (size
);
2487 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
2488 result
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
2489 result
->rank
= array
->rank
;
2490 result
->ts
= array
->ts
;
2495 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2496 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
2497 for (i
= 0; i
< arraysize
; i
++)
2499 arrayvec
[i
] = array_ctor
->expr
;
2500 array_ctor
= gfc_constructor_next (array_ctor
);
2503 resultvec
= XCNEWVEC (gfc_expr
*, arraysize
);
2508 for (d
=0; d
< array
->rank
; d
++)
2510 a_extent
[d
] = mpz_get_si (array
->shape
[d
]);
2511 a_stride
[d
] = d
== 0 ? 1 : a_stride
[d
-1] * a_extent
[d
-1];
2514 if (shift
->rank
> 0)
2516 shift_ctor
= gfc_constructor_first (shift
->value
.constructor
);
2522 shift_val
= mpz_get_si (shift
->value
.integer
);
2526 bnd_ctor
= gfc_constructor_first (bnd
->value
.constructor
);
2530 /* Shut up compiler */
2535 for (d
=0; d
< array
->rank
; d
++)
2539 rsoffset
= a_stride
[d
];
2545 extent
[n
] = a_extent
[d
];
2546 sstride
[n
] = a_stride
[d
];
2547 ss_ex
[n
] = sstride
[n
] * extent
[n
];
2553 continue_loop
= true;
2558 while (continue_loop
)
2563 sh
= mpz_get_si (shift_ctor
->expr
->value
.integer
);
2567 if (( sh
>= 0 ? sh
: -sh
) > len
)
2573 delta
= (sh
>= 0) ? sh
: -sh
;
2577 src
= &sptr
[delta
* rsoffset
];
2583 dest
= &rptr
[delta
* rsoffset
];
2586 for (n
= 0; n
< len
- delta
; n
++)
2602 *dest
= gfc_copy_expr (bnd_ctor
->expr
);
2610 *dest
= gfc_copy_expr (bnd
);
2617 shift_ctor
= gfc_constructor_next (shift_ctor
);
2620 bnd_ctor
= gfc_constructor_next (bnd_ctor
);
2624 while (count
[n
] == extent
[n
])
2632 continue_loop
= false;
2644 for (i
= 0; i
< arraysize
; i
++)
2646 gfc_constructor_append_expr (&result
->value
.constructor
,
2647 gfc_copy_expr (resultvec
[i
]),
2653 gfc_free_expr (bnd
);
2659 gfc_simplify_erf (gfc_expr
*x
)
2663 if (x
->expr_type
!= EXPR_CONSTANT
)
2666 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2667 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2669 return range_check (result
, "ERF");
2674 gfc_simplify_erfc (gfc_expr
*x
)
2678 if (x
->expr_type
!= EXPR_CONSTANT
)
2681 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2682 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2684 return range_check (result
, "ERFC");
2688 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2690 #define MAX_ITER 200
2691 #define ARG_LIMIT 12
2693 /* Calculate ERFC_SCALED directly by its definition:
2695 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2697 using a large precision for intermediate results. This is used for all
2698 but large values of the argument. */
2700 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2705 prec
= mpfr_get_default_prec ();
2706 mpfr_set_default_prec (10 * prec
);
2711 mpfr_set (a
, arg
, GFC_RND_MODE
);
2712 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2713 mpfr_exp (b
, b
, GFC_RND_MODE
);
2714 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2715 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2717 mpfr_set (res
, a
, GFC_RND_MODE
);
2718 mpfr_set_default_prec (prec
);
2724 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2726 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2727 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2730 This is used for large values of the argument. Intermediate calculations
2731 are performed with twice the precision. We don't do a fixed number of
2732 iterations of the sum, but stop when it has converged to the required
2735 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2737 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2742 prec
= mpfr_get_default_prec ();
2743 mpfr_set_default_prec (2 * prec
);
2753 mpfr_init (sumtrunc
);
2754 mpfr_set_prec (oldsum
, prec
);
2755 mpfr_set_prec (sumtrunc
, prec
);
2757 mpfr_set (x
, arg
, GFC_RND_MODE
);
2758 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2759 mpz_set_ui (num
, 1);
2761 mpfr_set (u
, x
, GFC_RND_MODE
);
2762 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2763 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2764 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2766 for (i
= 1; i
< MAX_ITER
; i
++)
2768 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2770 mpz_mul_ui (num
, num
, 2 * i
- 1);
2773 mpfr_set (w
, u
, GFC_RND_MODE
);
2774 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2776 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2777 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2779 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2781 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2782 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2786 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2788 gcc_assert (i
< MAX_ITER
);
2790 /* Divide by x * sqrt(Pi). */
2791 mpfr_const_pi (u
, GFC_RND_MODE
);
2792 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2793 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2794 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2796 mpfr_set (res
, sum
, GFC_RND_MODE
);
2797 mpfr_set_default_prec (prec
);
2799 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2805 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2809 if (x
->expr_type
!= EXPR_CONSTANT
)
2812 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2813 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2814 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2816 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2818 return range_check (result
, "ERFC_SCALED");
2826 gfc_simplify_epsilon (gfc_expr
*e
)
2831 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2833 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2834 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2836 return range_check (result
, "EPSILON");
2841 gfc_simplify_exp (gfc_expr
*x
)
2845 if (x
->expr_type
!= EXPR_CONSTANT
)
2848 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2853 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2857 gfc_set_model_kind (x
->ts
.kind
);
2858 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2862 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2865 return range_check (result
, "EXP");
2870 gfc_simplify_exponent (gfc_expr
*x
)
2875 if (x
->expr_type
!= EXPR_CONSTANT
)
2878 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2881 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2882 if (mpfr_inf_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
2884 int i
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
2885 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2889 /* EXPONENT(+/- 0.0) = 0 */
2890 if (mpfr_zero_p (x
->value
.real
))
2892 mpz_set_ui (result
->value
.integer
, 0);
2896 gfc_set_model (x
->value
.real
);
2898 val
= (long int) mpfr_get_exp (x
->value
.real
);
2899 mpz_set_si (result
->value
.integer
, val
);
2901 return range_check (result
, "EXPONENT");
2906 gfc_simplify_failed_or_stopped_images (gfc_expr
*team ATTRIBUTE_UNUSED
,
2909 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2911 gfc_current_locus
= *gfc_current_intrinsic_where
;
2912 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2913 return &gfc_bad_expr
;
2916 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2921 gfc_extract_int (kind
, &actual_kind
);
2923 actual_kind
= gfc_default_integer_kind
;
2925 result
= gfc_get_array_expr (BT_INTEGER
, actual_kind
, &gfc_current_locus
);
2930 /* For fcoarray = lib no simplification is possible, because it is not known
2931 what images failed or are stopped at compile time. */
2937 gfc_simplify_get_team (gfc_expr
*level ATTRIBUTE_UNUSED
)
2939 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2941 gfc_current_locus
= *gfc_current_intrinsic_where
;
2942 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2943 return &gfc_bad_expr
;
2946 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2949 result
= gfc_get_array_expr (BT_INTEGER
, gfc_default_integer_kind
, &gfc_current_locus
);
2954 /* For fcoarray = lib no simplification is possible, because it is not known
2955 what images failed or are stopped at compile time. */
2961 gfc_simplify_float (gfc_expr
*a
)
2965 if (a
->expr_type
!= EXPR_CONSTANT
)
2970 if (convert_boz (a
, gfc_default_real_kind
) == &gfc_bad_expr
)
2971 return &gfc_bad_expr
;
2973 result
= gfc_copy_expr (a
);
2976 result
= gfc_int2real (a
, gfc_default_real_kind
);
2978 return range_check (result
, "FLOAT");
2983 is_last_ref_vtab (gfc_expr
*e
)
2986 gfc_component
*comp
= NULL
;
2988 if (e
->expr_type
!= EXPR_VARIABLE
)
2991 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2992 if (ref
->type
== REF_COMPONENT
)
2993 comp
= ref
->u
.c
.component
;
2995 if (!e
->ref
|| !comp
)
2996 return e
->symtree
->n
.sym
->attr
.vtab
;
2998 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
3006 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
3008 /* Avoid simplification of resolved symbols. */
3009 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
3012 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
3013 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3014 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3017 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
3020 /* Return .false. if the dynamic type can never be an extension. */
3021 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
3022 && !gfc_type_is_extension_of
3023 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
3024 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
3025 && !gfc_type_is_extension_of
3026 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
3027 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
3028 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
3029 && !gfc_type_is_extension_of
3030 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
3032 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3033 && !gfc_type_is_extension_of
3034 (mold
->ts
.u
.derived
,
3035 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
3036 && !gfc_type_is_extension_of
3037 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
3038 mold
->ts
.u
.derived
)))
3039 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3041 /* Return .true. if the dynamic type is guaranteed to be an extension. */
3042 if (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
3043 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
3044 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
3045 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
3052 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
3054 /* Avoid simplification of resolved symbols. */
3055 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
3058 /* Return .false. if the dynamic type can never be the
3060 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
3061 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
3062 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
3063 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
3064 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
3066 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
3069 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3070 gfc_compare_derived_types (a
->ts
.u
.derived
,
3076 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
3082 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
3084 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3086 if (e
->expr_type
!= EXPR_CONSTANT
)
3089 mpfr_init2 (floor
, mpfr_get_prec (e
->value
.real
));
3090 mpfr_floor (floor
, e
->value
.real
);
3092 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
3093 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
3097 return range_check (result
, "FLOOR");
3102 gfc_simplify_fraction (gfc_expr
*x
)
3106 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
3107 mpfr_t absv
, exp
, pow2
;
3112 if (x
->expr_type
!= EXPR_CONSTANT
)
3115 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
3117 /* FRACTION(inf) = NaN. */
3118 if (mpfr_inf_p (x
->value
.real
))
3120 mpfr_set_nan (result
->value
.real
);
3124 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
3126 /* MPFR versions before 3.1.0 do not include mpfr_frexp.
3127 TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
3129 if (mpfr_sgn (x
->value
.real
) == 0)
3131 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3135 gfc_set_model_kind (x
->ts
.kind
);
3140 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
3141 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
3143 mpfr_trunc (exp
, exp
);
3144 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
3146 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
3148 mpfr_div (result
->value
.real
, x
->value
.real
, pow2
, GFC_RND_MODE
);
3150 mpfr_clears (exp
, absv
, pow2
, NULL
);
3154 /* mpfr_frexp() correctly handles zeros and NaNs. */
3155 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3159 return range_check (result
, "FRACTION");
3164 gfc_simplify_gamma (gfc_expr
*x
)
3168 if (x
->expr_type
!= EXPR_CONSTANT
)
3171 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3172 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3174 return range_check (result
, "GAMMA");
3179 gfc_simplify_huge (gfc_expr
*e
)
3184 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3185 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3190 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
3194 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
3206 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
3210 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3213 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3214 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
3215 return range_check (result
, "HYPOT");
3219 /* We use the processor's collating sequence, because all
3220 systems that gfortran currently works on are ASCII. */
3223 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
3229 if (e
->expr_type
!= EXPR_CONSTANT
)
3232 if (e
->value
.character
.length
!= 1)
3234 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
3235 return &gfc_bad_expr
;
3238 index
= e
->value
.character
.string
[0];
3240 if (warn_surprising
&& index
> 127)
3241 gfc_warning (OPT_Wsurprising
,
3242 "Argument of IACHAR function at %L outside of range 0..127",
3245 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
3247 return &gfc_bad_expr
;
3249 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3251 return range_check (result
, "IACHAR");
3256 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
3258 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3259 gcc_assert (result
->ts
.type
== BT_INTEGER
3260 && result
->expr_type
== EXPR_CONSTANT
);
3262 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3268 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3270 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
3275 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
3277 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3278 gcc_assert (result
->ts
.type
== BT_INTEGER
3279 && result
->expr_type
== EXPR_CONSTANT
);
3281 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3287 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3289 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
3294 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
3298 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3301 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3302 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3304 return range_check (result
, "IAND");
3309 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
3314 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3317 gfc_extract_int (y
, &pos
);
3319 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3321 result
= gfc_copy_expr (x
);
3323 convert_mpz_to_unsigned (result
->value
.integer
,
3324 gfc_integer_kinds
[k
].bit_size
);
3326 mpz_clrbit (result
->value
.integer
, pos
);
3328 gfc_convert_mpz_to_signed (result
->value
.integer
,
3329 gfc_integer_kinds
[k
].bit_size
);
3336 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
3343 if (x
->expr_type
!= EXPR_CONSTANT
3344 || y
->expr_type
!= EXPR_CONSTANT
3345 || z
->expr_type
!= EXPR_CONSTANT
)
3348 gfc_extract_int (y
, &pos
);
3349 gfc_extract_int (z
, &len
);
3351 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
3353 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3355 if (pos
+ len
> bitsize
)
3357 gfc_error ("Sum of second and third arguments of IBITS exceeds "
3358 "bit size at %L", &y
->where
);
3359 return &gfc_bad_expr
;
3362 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3363 convert_mpz_to_unsigned (result
->value
.integer
,
3364 gfc_integer_kinds
[k
].bit_size
);
3366 bits
= XCNEWVEC (int, bitsize
);
3368 for (i
= 0; i
< bitsize
; i
++)
3371 for (i
= 0; i
< len
; i
++)
3372 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
3374 for (i
= 0; i
< bitsize
; i
++)
3377 mpz_clrbit (result
->value
.integer
, i
);
3378 else if (bits
[i
] == 1)
3379 mpz_setbit (result
->value
.integer
, i
);
3381 gfc_internal_error ("IBITS: Bad bit");
3386 gfc_convert_mpz_to_signed (result
->value
.integer
,
3387 gfc_integer_kinds
[k
].bit_size
);
3394 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
3399 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3402 gfc_extract_int (y
, &pos
);
3404 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
3406 result
= gfc_copy_expr (x
);
3408 convert_mpz_to_unsigned (result
->value
.integer
,
3409 gfc_integer_kinds
[k
].bit_size
);
3411 mpz_setbit (result
->value
.integer
, pos
);
3413 gfc_convert_mpz_to_signed (result
->value
.integer
,
3414 gfc_integer_kinds
[k
].bit_size
);
3421 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
3427 if (e
->expr_type
!= EXPR_CONSTANT
)
3430 if (e
->value
.character
.length
!= 1)
3432 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
3433 return &gfc_bad_expr
;
3436 index
= e
->value
.character
.string
[0];
3438 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
3440 return &gfc_bad_expr
;
3442 result
= gfc_get_int_expr (k
, &e
->where
, index
);
3444 return range_check (result
, "ICHAR");
3449 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
3453 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3456 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3457 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3459 return range_check (result
, "IEOR");
3464 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
3467 int back
, len
, lensub
;
3468 int i
, j
, k
, count
, index
= 0, start
;
3470 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
3471 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
3474 if (b
!= NULL
&& b
->value
.logical
!= 0)
3479 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
3481 return &gfc_bad_expr
;
3483 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
3485 len
= x
->value
.character
.length
;
3486 lensub
= y
->value
.character
.length
;
3490 mpz_set_si (result
->value
.integer
, 0);
3498 mpz_set_si (result
->value
.integer
, 1);
3501 else if (lensub
== 1)
3503 for (i
= 0; i
< len
; i
++)
3505 for (j
= 0; j
< lensub
; j
++)
3507 if (y
->value
.character
.string
[j
]
3508 == x
->value
.character
.string
[i
])
3518 for (i
= 0; i
< len
; i
++)
3520 for (j
= 0; j
< lensub
; j
++)
3522 if (y
->value
.character
.string
[j
]
3523 == x
->value
.character
.string
[i
])
3528 for (k
= 0; k
< lensub
; k
++)
3530 if (y
->value
.character
.string
[k
]
3531 == x
->value
.character
.string
[k
+ start
])
3535 if (count
== lensub
)
3550 mpz_set_si (result
->value
.integer
, len
+ 1);
3553 else if (lensub
== 1)
3555 for (i
= 0; i
< len
; i
++)
3557 for (j
= 0; j
< lensub
; j
++)
3559 if (y
->value
.character
.string
[j
]
3560 == x
->value
.character
.string
[len
- i
])
3562 index
= len
- i
+ 1;
3570 for (i
= 0; i
< len
; i
++)
3572 for (j
= 0; j
< lensub
; j
++)
3574 if (y
->value
.character
.string
[j
]
3575 == x
->value
.character
.string
[len
- i
])
3578 if (start
<= len
- lensub
)
3581 for (k
= 0; k
< lensub
; k
++)
3582 if (y
->value
.character
.string
[k
]
3583 == x
->value
.character
.string
[k
+ start
])
3586 if (count
== lensub
)
3603 mpz_set_si (result
->value
.integer
, index
);
3604 return range_check (result
, "INDEX");
3609 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
3611 gfc_expr
*result
= NULL
;
3613 if (e
->expr_type
!= EXPR_CONSTANT
)
3616 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
3617 if (result
== &gfc_bad_expr
)
3618 return &gfc_bad_expr
;
3620 return range_check (result
, name
);
3625 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
3629 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
3631 return &gfc_bad_expr
;
3633 return simplify_intconv (e
, kind
, "INT");
3637 gfc_simplify_int2 (gfc_expr
*e
)
3639 return simplify_intconv (e
, 2, "INT2");
3644 gfc_simplify_int8 (gfc_expr
*e
)
3646 return simplify_intconv (e
, 8, "INT8");
3651 gfc_simplify_long (gfc_expr
*e
)
3653 return simplify_intconv (e
, 4, "LONG");
3658 gfc_simplify_ifix (gfc_expr
*e
)
3660 gfc_expr
*rtrunc
, *result
;
3662 if (e
->expr_type
!= EXPR_CONSTANT
)
3665 rtrunc
= gfc_copy_expr (e
);
3666 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3668 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3670 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3672 gfc_free_expr (rtrunc
);
3674 return range_check (result
, "IFIX");
3679 gfc_simplify_idint (gfc_expr
*e
)
3681 gfc_expr
*rtrunc
, *result
;
3683 if (e
->expr_type
!= EXPR_CONSTANT
)
3686 rtrunc
= gfc_copy_expr (e
);
3687 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3689 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3691 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3693 gfc_free_expr (rtrunc
);
3695 return range_check (result
, "IDINT");
3700 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
3704 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3707 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3708 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3710 return range_check (result
, "IOR");
3715 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
3717 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3718 gcc_assert (result
->ts
.type
== BT_INTEGER
3719 && result
->expr_type
== EXPR_CONSTANT
);
3721 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3727 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3729 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3734 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3736 if (x
->expr_type
!= EXPR_CONSTANT
)
3739 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3740 mpz_cmp_si (x
->value
.integer
,
3741 LIBERROR_END
) == 0);
3746 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3748 if (x
->expr_type
!= EXPR_CONSTANT
)
3751 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3752 mpz_cmp_si (x
->value
.integer
,
3753 LIBERROR_EOR
) == 0);
3758 gfc_simplify_isnan (gfc_expr
*x
)
3760 if (x
->expr_type
!= EXPR_CONSTANT
)
3763 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3764 mpfr_nan_p (x
->value
.real
));
3768 /* Performs a shift on its first argument. Depending on the last
3769 argument, the shift can be arithmetic, i.e. with filling from the
3770 left like in the SHIFTA intrinsic. */
3772 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3773 bool arithmetic
, int direction
)
3776 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3778 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3781 gfc_extract_int (s
, &shift
);
3783 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3784 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3786 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3790 mpz_set (result
->value
.integer
, e
->value
.integer
);
3794 if (direction
> 0 && shift
< 0)
3796 /* Left shift, as in SHIFTL. */
3797 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3798 return &gfc_bad_expr
;
3800 else if (direction
< 0)
3802 /* Right shift, as in SHIFTR or SHIFTA. */
3805 gfc_error ("Second argument of %s is negative at %L",
3807 return &gfc_bad_expr
;
3813 ashift
= (shift
>= 0 ? shift
: -shift
);
3815 if (ashift
> bitsize
)
3817 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3818 "at %L", name
, &e
->where
);
3819 return &gfc_bad_expr
;
3822 bits
= XCNEWVEC (int, bitsize
);
3824 for (i
= 0; i
< bitsize
; i
++)
3825 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3830 for (i
= 0; i
< shift
; i
++)
3831 mpz_clrbit (result
->value
.integer
, i
);
3833 for (i
= 0; i
< bitsize
- shift
; i
++)
3836 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3838 mpz_setbit (result
->value
.integer
, i
+ shift
);
3844 if (arithmetic
&& bits
[bitsize
- 1])
3845 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3846 mpz_setbit (result
->value
.integer
, i
);
3848 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3849 mpz_clrbit (result
->value
.integer
, i
);
3851 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3854 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3856 mpz_setbit (result
->value
.integer
, i
- ashift
);
3860 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3868 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3870 return simplify_shift (e
, s
, "ISHFT", false, 0);
3875 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3877 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3882 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3884 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3889 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3891 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3896 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3898 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3903 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3905 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3910 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3913 int shift
, ashift
, isize
, ssize
, delta
, k
;
3916 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3919 gfc_extract_int (s
, &shift
);
3921 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3922 isize
= gfc_integer_kinds
[k
].bit_size
;
3926 if (sz
->expr_type
!= EXPR_CONSTANT
)
3929 gfc_extract_int (sz
, &ssize
);
3942 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3943 "BIT_SIZE of first argument at %C");
3945 gfc_error ("Absolute value of SHIFT shall be less than or equal "
3947 return &gfc_bad_expr
;
3950 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3952 mpz_set (result
->value
.integer
, e
->value
.integer
);
3957 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
3959 bits
= XCNEWVEC (int, ssize
);
3961 for (i
= 0; i
< ssize
; i
++)
3962 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3964 delta
= ssize
- ashift
;
3968 for (i
= 0; i
< delta
; i
++)
3971 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3973 mpz_setbit (result
->value
.integer
, i
+ shift
);
3976 for (i
= delta
; i
< ssize
; i
++)
3979 mpz_clrbit (result
->value
.integer
, i
- delta
);
3981 mpz_setbit (result
->value
.integer
, i
- delta
);
3986 for (i
= 0; i
< ashift
; i
++)
3989 mpz_clrbit (result
->value
.integer
, i
+ delta
);
3991 mpz_setbit (result
->value
.integer
, i
+ delta
);
3994 for (i
= ashift
; i
< ssize
; i
++)
3997 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3999 mpz_setbit (result
->value
.integer
, i
+ shift
);
4003 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
4011 gfc_simplify_kind (gfc_expr
*e
)
4013 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
4018 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
4019 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
4021 gfc_expr
*l
, *u
, *result
;
4024 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4025 gfc_default_integer_kind
);
4027 return &gfc_bad_expr
;
4029 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4031 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
4032 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
4033 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
4037 gfc_expr
* dim
= result
;
4038 mpz_set_si (dim
->value
.integer
, d
);
4040 result
= simplify_size (array
, dim
, k
);
4041 gfc_free_expr (dim
);
4046 mpz_set_si (result
->value
.integer
, 1);
4051 /* Otherwise, we have a variable expression. */
4052 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
4055 if (!gfc_resolve_array_spec (as
, 0))
4058 /* The last dimension of an assumed-size array is special. */
4059 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
4060 || (coarray
&& d
== as
->rank
+ as
->corank
4061 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
4063 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
4065 gfc_free_expr (result
);
4066 return gfc_copy_expr (as
->lower
[d
-1]);
4072 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
4074 /* Then, we need to know the extent of the given dimension. */
4075 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
4077 gfc_expr
*declared_bound
;
4079 bool constant_lbound
, constant_ubound
;
4084 gcc_assert (l
!= NULL
);
4086 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
4087 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
4089 empty_bound
= upper
? 0 : 1;
4090 declared_bound
= upper
? u
: l
;
4092 if ((!upper
&& !constant_lbound
)
4093 || (upper
&& !constant_ubound
))
4098 /* For {L,U}BOUND, the value depends on whether the array
4099 is empty. We can nevertheless simplify if the declared bound
4100 has the same value as that of an empty array, in which case
4101 the result isn't dependent on the array emptyness. */
4102 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
4103 mpz_set_si (result
->value
.integer
, empty_bound
);
4104 else if (!constant_lbound
|| !constant_ubound
)
4105 /* Array emptyness can't be determined, we can't simplify. */
4107 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
4108 mpz_set_si (result
->value
.integer
, empty_bound
);
4110 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4113 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
4119 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d
- 1, &result
->value
.integer
, NULL
))
4123 mpz_set_si (result
->value
.integer
, (long int) 1);
4127 return range_check (result
, upper
? "UBOUND" : "LBOUND");
4130 gfc_free_expr (result
);
4136 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4142 if (array
->ts
.type
== BT_CLASS
)
4145 if (array
->expr_type
!= EXPR_VARIABLE
)
4152 /* Follow any component references. */
4153 as
= array
->symtree
->n
.sym
->as
;
4154 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4159 switch (ref
->u
.ar
.type
)
4166 /* We're done because 'as' has already been set in the
4167 previous iteration. */
4181 as
= ref
->u
.c
.component
->as
;
4194 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
4195 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
4199 || (as
->type
!= AS_DEFERRED
4200 && array
->expr_type
== EXPR_VARIABLE
4201 && !gfc_expr_attr (array
).allocatable
4202 && !gfc_expr_attr (array
).pointer
));
4206 /* Multi-dimensional bounds. */
4207 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4211 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4212 if (upper
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
4214 /* An error message will be emitted in
4215 check_assumed_size_reference (resolve.c). */
4216 return &gfc_bad_expr
;
4219 /* Simplify the bounds for each dimension. */
4220 for (d
= 0; d
< array
->rank
; d
++)
4222 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
4224 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4228 for (j
= 0; j
< d
; j
++)
4229 gfc_free_expr (bounds
[j
]);
4234 /* Allocate the result expression. */
4235 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
4236 gfc_default_integer_kind
);
4238 return &gfc_bad_expr
;
4240 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
4242 /* The result is a rank 1 array; its size is the rank of the first
4243 argument to {L,U}BOUND. */
4245 e
->shape
= gfc_get_shape (1);
4246 mpz_init_set_ui (e
->shape
[0], array
->rank
);
4248 /* Create the constructor for this array. */
4249 for (d
= 0; d
< array
->rank
; d
++)
4250 gfc_constructor_append_expr (&e
->value
.constructor
,
4251 bounds
[d
], &e
->where
);
4257 /* A DIM argument is specified. */
4258 if (dim
->expr_type
!= EXPR_CONSTANT
)
4261 d
= mpz_get_si (dim
->value
.integer
);
4263 if ((d
< 1 || d
> array
->rank
)
4264 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
4266 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4267 return &gfc_bad_expr
;
4270 if (as
&& as
->type
== AS_ASSUMED_RANK
)
4273 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
4279 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
4285 if (array
->expr_type
!= EXPR_VARIABLE
)
4288 /* Follow any component references. */
4289 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
4290 ? array
->ts
.u
.derived
->components
->as
4291 : array
->symtree
->n
.sym
->as
;
4292 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
4297 switch (ref
->u
.ar
.type
)
4300 if (ref
->u
.ar
.as
->corank
> 0)
4302 gcc_assert (as
== ref
->u
.ar
.as
);
4309 /* We're done because 'as' has already been set in the
4310 previous iteration. */
4324 as
= ref
->u
.c
.component
->as
;
4338 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
4343 /* Multi-dimensional cobounds. */
4344 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
4348 /* Simplify the cobounds for each dimension. */
4349 for (d
= 0; d
< as
->corank
; d
++)
4351 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
4352 upper
, as
, ref
, true);
4353 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
4357 for (j
= 0; j
< d
; j
++)
4358 gfc_free_expr (bounds
[j
]);
4363 /* Allocate the result expression. */
4364 e
= gfc_get_expr ();
4365 e
->where
= array
->where
;
4366 e
->expr_type
= EXPR_ARRAY
;
4367 e
->ts
.type
= BT_INTEGER
;
4368 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
4369 gfc_default_integer_kind
);
4373 return &gfc_bad_expr
;
4377 /* The result is a rank 1 array; its size is the rank of the first
4378 argument to {L,U}COBOUND. */
4380 e
->shape
= gfc_get_shape (1);
4381 mpz_init_set_ui (e
->shape
[0], as
->corank
);
4383 /* Create the constructor for this array. */
4384 for (d
= 0; d
< as
->corank
; d
++)
4385 gfc_constructor_append_expr (&e
->value
.constructor
,
4386 bounds
[d
], &e
->where
);
4391 /* A DIM argument is specified. */
4392 if (dim
->expr_type
!= EXPR_CONSTANT
)
4395 d
= mpz_get_si (dim
->value
.integer
);
4397 if (d
< 1 || d
> as
->corank
)
4399 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
4400 return &gfc_bad_expr
;
4403 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
4409 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4411 return simplify_bound (array
, dim
, kind
, 0);
4416 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
4418 return simplify_cobound (array
, dim
, kind
, 0);
4422 gfc_simplify_leadz (gfc_expr
*e
)
4424 unsigned long lz
, bs
;
4427 if (e
->expr_type
!= EXPR_CONSTANT
)
4430 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4431 bs
= gfc_integer_kinds
[i
].bit_size
;
4432 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
4434 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
4437 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
4439 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
4444 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
4447 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
4450 return &gfc_bad_expr
;
4452 if (e
->expr_type
== EXPR_CONSTANT
)
4454 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4455 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
4456 return range_check (result
, "LEN");
4458 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
4459 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
4460 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
4462 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4463 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
4464 return range_check (result
, "LEN");
4466 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
4467 && e
->symtree
->n
.sym
4468 && e
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
4469 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
4470 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
4471 && e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
4472 && UNLIMITED_POLY (e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
))
4474 /* The expression in assoc->target points to a ref to the _data component
4475 of the unlimited polymorphic entity. To get the _len component the last
4476 _data ref needs to be stripped and a ref to the _len component added. */
4477 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
);
4484 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
4487 size_t count
, len
, i
;
4488 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
4491 return &gfc_bad_expr
;
4493 if (e
->expr_type
!= EXPR_CONSTANT
)
4496 len
= e
->value
.character
.length
;
4497 for (count
= 0, i
= 1; i
<= len
; i
++)
4498 if (e
->value
.character
.string
[len
- i
] == ' ')
4503 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
4504 return range_check (result
, "LEN_TRIM");
4508 gfc_simplify_lgamma (gfc_expr
*x
)
4513 if (x
->expr_type
!= EXPR_CONSTANT
)
4516 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4517 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
4519 return range_check (result
, "LGAMMA");
4524 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
4526 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4529 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4530 gfc_compare_string (a
, b
) >= 0);
4535 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
4537 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4540 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4541 gfc_compare_string (a
, b
) > 0);
4546 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
4548 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4551 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4552 gfc_compare_string (a
, b
) <= 0);
4557 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
4559 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4562 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4563 gfc_compare_string (a
, b
) < 0);
4568 gfc_simplify_log (gfc_expr
*x
)
4572 if (x
->expr_type
!= EXPR_CONSTANT
)
4575 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4580 if (mpfr_sgn (x
->value
.real
) <= 0)
4582 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4583 "to zero", &x
->where
);
4584 gfc_free_expr (result
);
4585 return &gfc_bad_expr
;
4588 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4592 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
4593 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
4595 gfc_error ("Complex argument of LOG at %L cannot be zero",
4597 gfc_free_expr (result
);
4598 return &gfc_bad_expr
;
4601 gfc_set_model_kind (x
->ts
.kind
);
4602 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
4606 gfc_internal_error ("gfc_simplify_log: bad type");
4609 return range_check (result
, "LOG");
4614 gfc_simplify_log10 (gfc_expr
*x
)
4618 if (x
->expr_type
!= EXPR_CONSTANT
)
4621 if (mpfr_sgn (x
->value
.real
) <= 0)
4623 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4624 "to zero", &x
->where
);
4625 return &gfc_bad_expr
;
4628 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4629 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4631 return range_check (result
, "LOG10");
4636 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
4640 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
4642 return &gfc_bad_expr
;
4644 if (e
->expr_type
!= EXPR_CONSTANT
)
4647 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
4652 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
4655 int row
, result_rows
, col
, result_columns
;
4656 int stride_a
, offset_a
, stride_b
, offset_b
;
4658 if (!is_constant_array_expr (matrix_a
)
4659 || !is_constant_array_expr (matrix_b
))
4662 /* MATMUL should do mixed-mode arithmetic. Set the result type. */
4663 if (matrix_a
->ts
.type
!= matrix_b
->ts
.type
)
4666 e
.expr_type
= EXPR_OP
;
4667 gfc_clear_ts (&e
.ts
);
4668 e
.value
.op
.op
= INTRINSIC_NONE
;
4669 e
.value
.op
.op1
= matrix_a
;
4670 e
.value
.op
.op2
= matrix_b
;
4671 gfc_type_convert_binary (&e
, 1);
4672 result
= gfc_get_array_expr (e
.ts
.type
, e
.ts
.kind
, &matrix_a
->where
);
4676 result
= gfc_get_array_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
4680 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
4683 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4685 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4688 result
->shape
= gfc_get_shape (result
->rank
);
4689 mpz_init_set_si (result
->shape
[0], result_columns
);
4691 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
4693 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4695 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4699 result
->shape
= gfc_get_shape (result
->rank
);
4700 mpz_init_set_si (result
->shape
[0], result_rows
);
4702 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
4704 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4705 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4706 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4707 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4710 result
->shape
= gfc_get_shape (result
->rank
);
4711 mpz_init_set_si (result
->shape
[0], result_rows
);
4712 mpz_init_set_si (result
->shape
[1], result_columns
);
4717 offset_a
= offset_b
= 0;
4718 for (col
= 0; col
< result_columns
; ++col
)
4722 for (row
= 0; row
< result_rows
; ++row
)
4724 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
4725 matrix_b
, 1, offset_b
, false);
4726 gfc_constructor_append_expr (&result
->value
.constructor
,
4732 offset_b
+= stride_b
;
4740 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
4745 if (i
->expr_type
!= EXPR_CONSTANT
)
4748 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
4750 return &gfc_bad_expr
;
4751 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4753 bool fail
= gfc_extract_int (i
, &arg
);
4756 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4758 /* MASKR(n) = 2^n - 1 */
4759 mpz_set_ui (result
->value
.integer
, 1);
4760 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4761 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4763 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4770 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4776 if (i
->expr_type
!= EXPR_CONSTANT
)
4779 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4781 return &gfc_bad_expr
;
4782 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4784 bool fail
= gfc_extract_int (i
, &arg
);
4787 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4789 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4790 mpz_init_set_ui (z
, 1);
4791 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4792 mpz_set_ui (result
->value
.integer
, 1);
4793 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4794 gfc_integer_kinds
[k
].bit_size
- arg
);
4795 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4798 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4805 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4808 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4810 if (mask
->expr_type
== EXPR_CONSTANT
)
4811 return gfc_get_parentheses (gfc_copy_expr (mask
->value
.logical
4812 ? tsource
: fsource
));
4814 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4815 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4818 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4820 if (tsource
->ts
.type
== BT_DERIVED
)
4821 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4822 else if (tsource
->ts
.type
== BT_CHARACTER
)
4823 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4825 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4826 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4827 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4831 if (mask_ctor
->expr
->value
.logical
)
4832 gfc_constructor_append_expr (&result
->value
.constructor
,
4833 gfc_copy_expr (tsource_ctor
->expr
),
4836 gfc_constructor_append_expr (&result
->value
.constructor
,
4837 gfc_copy_expr (fsource_ctor
->expr
),
4839 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4840 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4841 mask_ctor
= gfc_constructor_next (mask_ctor
);
4844 result
->shape
= gfc_get_shape (1);
4845 gfc_array_size (result
, &result
->shape
[0]);
4852 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4854 mpz_t arg1
, arg2
, mask
;
4857 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4858 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4861 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4863 /* Convert all argument to unsigned. */
4864 mpz_init_set (arg1
, i
->value
.integer
);
4865 mpz_init_set (arg2
, j
->value
.integer
);
4866 mpz_init_set (mask
, mask_expr
->value
.integer
);
4868 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4869 mpz_and (arg1
, arg1
, mask
);
4870 mpz_com (mask
, mask
);
4871 mpz_and (arg2
, arg2
, mask
);
4872 mpz_ior (result
->value
.integer
, arg1
, arg2
);
4882 /* Selects between current value and extremum for simplify_min_max
4883 and simplify_minval_maxval. */
4885 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
, bool back_val
)
4889 switch (arg
->ts
.type
)
4892 ret
= mpz_cmp (arg
->value
.integer
,
4893 extremum
->value
.integer
) * sign
;
4895 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
4899 if (mpfr_nan_p (extremum
->value
.real
))
4902 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
4904 else if (mpfr_nan_p (arg
->value
.real
))
4908 ret
= mpfr_cmp (arg
->value
.real
, extremum
->value
.real
) * sign
;
4910 mpfr_set (extremum
->value
.real
, arg
->value
.real
, GFC_RND_MODE
);
4915 #define LENGTH(x) ((x)->value.character.length)
4916 #define STRING(x) ((x)->value.character.string)
4917 if (LENGTH (extremum
) < LENGTH(arg
))
4919 gfc_char_t
*tmp
= STRING(extremum
);
4921 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
4922 memcpy (STRING(extremum
), tmp
,
4923 LENGTH(extremum
) * sizeof (gfc_char_t
));
4924 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
4925 LENGTH(arg
) - LENGTH(extremum
));
4926 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
4927 LENGTH(extremum
) = LENGTH(arg
);
4930 ret
= gfc_compare_string (arg
, extremum
) * sign
;
4933 free (STRING(extremum
));
4934 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
4935 memcpy (STRING(extremum
), STRING(arg
),
4936 LENGTH(arg
) * sizeof (gfc_char_t
));
4937 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
4938 LENGTH(extremum
) - LENGTH(arg
));
4939 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
4946 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4948 if (back_val
&& ret
== 0)
4955 /* This function is special since MAX() can take any number of
4956 arguments. The simplified expression is a rewritten version of the
4957 argument list containing at most one constant element. Other
4958 constant elements are deleted. Because the argument list has
4959 already been checked, this function always succeeds. sign is 1 for
4960 MAX(), -1 for MIN(). */
4963 simplify_min_max (gfc_expr
*expr
, int sign
)
4965 gfc_actual_arglist
*arg
, *last
, *extremum
;
4970 arg
= expr
->value
.function
.actual
;
4972 for (; arg
; last
= arg
, arg
= arg
->next
)
4974 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
4977 if (extremum
== NULL
)
4983 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
4985 /* Delete the extra constant argument. */
4986 last
->next
= arg
->next
;
4989 gfc_free_actual_arglist (arg
);
4993 /* If there is one value left, replace the function call with the
4995 if (expr
->value
.function
.actual
->next
!= NULL
)
4998 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
5003 gfc_simplify_min (gfc_expr
*e
)
5005 return simplify_min_max (e
, -1);
5010 gfc_simplify_max (gfc_expr
*e
)
5012 return simplify_min_max (e
, 1);
5015 /* Helper function for gfc_simplify_minval. */
5018 gfc_min (gfc_expr
*op1
, gfc_expr
*op2
)
5020 min_max_choose (op1
, op2
, -1);
5021 gfc_free_expr (op1
);
5025 /* Simplify minval for constant arrays. */
5028 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5030 return simplify_transformation (array
, dim
, mask
, INT_MAX
, gfc_min
);
5033 /* Helper function for gfc_simplify_maxval. */
5036 gfc_max (gfc_expr
*op1
, gfc_expr
*op2
)
5038 min_max_choose (op1
, op2
, 1);
5039 gfc_free_expr (op1
);
5044 /* Simplify maxval for constant arrays. */
5047 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
5049 return simplify_transformation (array
, dim
, mask
, INT_MIN
, gfc_max
);
5053 /* Transform minloc or maxloc of an array, according to MASK,
5054 to the scalar result. This code is mostly identical to
5055 simplify_transformation_to_scalar. */
5058 simplify_minmaxloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
5059 gfc_expr
*extremum
, int sign
, bool back_val
)
5062 gfc_constructor
*array_ctor
, *mask_ctor
;
5065 mpz_set_si (result
->value
.integer
, 0);
5068 /* Shortcut for constant .FALSE. MASK. */
5070 && mask
->expr_type
== EXPR_CONSTANT
5071 && !mask
->value
.logical
)
5074 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5075 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5076 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5080 mpz_init_set_si (count
, 0);
5083 mpz_add_ui (count
, count
, 1);
5084 a
= array_ctor
->expr
;
5085 array_ctor
= gfc_constructor_next (array_ctor
);
5086 /* A constant MASK equals .TRUE. here and can be ignored. */
5089 m
= mask_ctor
->expr
;
5090 mask_ctor
= gfc_constructor_next (mask_ctor
);
5091 if (!m
->value
.logical
)
5094 if (min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5095 mpz_set (result
->value
.integer
, count
);
5098 gfc_free_expr (extremum
);
5102 /* Simplify minloc / maxloc in the absence of a dim argument. */
5105 simplify_minmaxloc_nodim (gfc_expr
*result
, gfc_expr
*extremum
,
5106 gfc_expr
*array
, gfc_expr
*mask
, int sign
,
5109 ssize_t res
[GFC_MAX_DIMENSIONS
];
5111 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5112 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5113 sstride
[GFC_MAX_DIMENSIONS
];
5118 for (i
= 0; i
<array
->rank
; i
++)
5121 /* Shortcut for constant .FALSE. MASK. */
5123 && mask
->expr_type
== EXPR_CONSTANT
5124 && !mask
->value
.logical
)
5127 for (i
= 0; i
< array
->rank
; i
++)
5130 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5131 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5136 continue_loop
= true;
5137 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5138 if (mask
&& mask
->rank
> 0)
5139 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5143 /* Loop over the array elements (and mask), keeping track of
5144 the indices to return. */
5145 while (continue_loop
)
5149 a
= array_ctor
->expr
;
5152 m
= mask_ctor
->expr
;
5153 ma
= m
->value
.logical
;
5154 mask_ctor
= gfc_constructor_next (mask_ctor
);
5159 if (ma
&& min_max_choose (a
, extremum
, sign
, back_val
) > 0)
5161 for (i
= 0; i
<array
->rank
; i
++)
5164 array_ctor
= gfc_constructor_next (array_ctor
);
5166 } while (count
[0] != extent
[0]);
5170 /* When we get to the end of a dimension, reset it and increment
5171 the next dimension. */
5174 if (n
>= array
->rank
)
5176 continue_loop
= false;
5181 } while (count
[n
] == extent
[n
]);
5185 gfc_free_expr (extremum
);
5186 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5187 for (i
= 0; i
<array
->rank
; i
++)
5190 r_expr
= result_ctor
->expr
;
5191 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5192 result_ctor
= gfc_constructor_next (result_ctor
);
5197 /* Helper function for gfc_simplify_minmaxloc - build an array
5198 expression with n elements. */
5201 new_array (bt type
, int kind
, int n
, locus
*where
)
5206 result
= gfc_get_array_expr (type
, kind
, where
);
5208 result
->shape
= gfc_get_shape(1);
5209 mpz_init_set_si (result
->shape
[0], n
);
5210 for (i
= 0; i
< n
; i
++)
5212 gfc_constructor_append_expr (&result
->value
.constructor
,
5213 gfc_get_constant_expr (type
, kind
, where
),
5220 /* Simplify minloc and maxloc. This code is mostly identical to
5221 simplify_transformation_to_array. */
5224 simplify_minmaxloc_to_array (gfc_expr
*result
, gfc_expr
*array
,
5225 gfc_expr
*dim
, gfc_expr
*mask
,
5226 gfc_expr
*extremum
, int sign
, bool back_val
)
5229 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5230 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5231 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5233 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5234 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5235 tmpstride
[GFC_MAX_DIMENSIONS
];
5237 /* Shortcut for constant .FALSE. MASK. */
5239 && mask
->expr_type
== EXPR_CONSTANT
5240 && !mask
->value
.logical
)
5243 /* Build an indexed table for array element expressions to minimize
5244 linked-list traversal. Masked elements are set to NULL. */
5245 gfc_array_size (array
, &size
);
5246 arraysize
= mpz_get_ui (size
);
5249 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5251 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5253 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5254 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5256 for (i
= 0; i
< arraysize
; ++i
)
5258 arrayvec
[i
] = array_ctor
->expr
;
5259 array_ctor
= gfc_constructor_next (array_ctor
);
5263 if (!mask_ctor
->expr
->value
.logical
)
5266 mask_ctor
= gfc_constructor_next (mask_ctor
);
5270 /* Same for the result expression. */
5271 gfc_array_size (result
, &size
);
5272 resultsize
= mpz_get_ui (size
);
5275 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5276 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5277 for (i
= 0; i
< resultsize
; ++i
)
5279 resultvec
[i
] = result_ctor
->expr
;
5280 result_ctor
= gfc_constructor_next (result_ctor
);
5283 gfc_extract_int (dim
, &dim_index
);
5284 dim_index
-= 1; /* zero-base index */
5288 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5291 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5294 dim_extent
= mpz_get_si (array
->shape
[i
]);
5295 dim_stride
= tmpstride
[i
];
5299 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5300 sstride
[n
] = tmpstride
[i
];
5301 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5305 done
= resultsize
<= 0;
5311 ex
= gfc_copy_expr (extremum
);
5312 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5314 if (*src
&& min_max_choose (*src
, ex
, sign
, back_val
) > 0)
5315 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5324 while (!done
&& count
[n
] == extent
[n
])
5327 base
-= sstride
[n
] * extent
[n
];
5328 dest
-= dstride
[n
] * extent
[n
];
5331 if (n
< result
->rank
)
5333 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5334 times, we'd warn for the last iteration, because the
5335 array index will have already been incremented to the
5336 array sizes, and we can't tell that this must make
5337 the test against result->rank false, because ranks
5338 must not exceed GFC_MAX_DIMENSIONS. */
5339 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5350 /* Place updated expression in result constructor. */
5351 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5352 for (i
= 0; i
< resultsize
; ++i
)
5354 result_ctor
->expr
= resultvec
[i
];
5355 result_ctor
= gfc_constructor_next (result_ctor
);
5364 /* Simplify minloc and maxloc for constant arrays. */
5367 gfc_simplify_minmaxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
5368 gfc_expr
*kind
, gfc_expr
*back
, int sign
)
5374 bool back_val
= false;
5376 if (!is_constant_array_expr (array
)
5377 || !gfc_is_constant_expr (dim
))
5381 && !is_constant_array_expr (mask
)
5382 && mask
->expr_type
!= EXPR_CONSTANT
)
5387 if (gfc_extract_int (kind
, &ikind
, -1))
5391 ikind
= gfc_default_integer_kind
;
5395 if (back
->expr_type
!= EXPR_CONSTANT
)
5398 back_val
= back
->value
.logical
;
5408 extremum
= gfc_get_constant_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
5409 init_result_expr (extremum
, init_val
, array
);
5413 result
= transformational_result (array
, dim
, BT_INTEGER
,
5414 ikind
, &array
->where
);
5415 init_result_expr (result
, 0, array
);
5417 if (array
->rank
== 1)
5418 return simplify_minmaxloc_to_scalar (result
, array
, mask
, extremum
,
5421 return simplify_minmaxloc_to_array (result
, array
, dim
, mask
, extremum
,
5426 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5427 return simplify_minmaxloc_nodim (result
, extremum
, array
, mask
,
5433 gfc_simplify_minloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5436 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, -1);
5440 gfc_simplify_maxloc (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
, gfc_expr
*kind
,
5443 return gfc_simplify_minmaxloc (array
, dim
, mask
, kind
, back
, 1);
5446 /* Simplify findloc to scalar. Similar to
5447 simplify_minmaxloc_to_scalar. */
5450 simplify_findloc_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5451 gfc_expr
*mask
, int back_val
)
5454 gfc_constructor
*array_ctor
, *mask_ctor
;
5457 mpz_set_si (result
->value
.integer
, 0);
5459 /* Shortcut for constant .FALSE. MASK. */
5461 && mask
->expr_type
== EXPR_CONSTANT
5462 && !mask
->value
.logical
)
5465 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5466 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5467 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5471 mpz_init_set_si (count
, 0);
5474 mpz_add_ui (count
, count
, 1);
5475 a
= array_ctor
->expr
;
5476 array_ctor
= gfc_constructor_next (array_ctor
);
5477 /* A constant MASK equals .TRUE. here and can be ignored. */
5480 m
= mask_ctor
->expr
;
5481 mask_ctor
= gfc_constructor_next (mask_ctor
);
5482 if (!m
->value
.logical
)
5485 if (gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5487 /* We have a match. If BACK is true, continue so we find
5489 mpz_set (result
->value
.integer
, count
);
5498 /* Simplify findloc in the absence of a dim argument. Similar to
5499 simplify_minmaxloc_nodim. */
5502 simplify_findloc_nodim (gfc_expr
*result
, gfc_expr
*value
, gfc_expr
*array
,
5503 gfc_expr
*mask
, bool back_val
)
5505 ssize_t res
[GFC_MAX_DIMENSIONS
];
5507 gfc_constructor
*result_ctor
, *array_ctor
, *mask_ctor
;
5508 ssize_t count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5509 sstride
[GFC_MAX_DIMENSIONS
];
5514 for (i
= 0; i
<array
->rank
; i
++)
5517 /* Shortcut for constant .FALSE. MASK. */
5519 && mask
->expr_type
== EXPR_CONSTANT
5520 && !mask
->value
.logical
)
5523 for (i
= 0; i
< array
->rank
; i
++)
5526 sstride
[i
] = (i
== 0) ? 1 : sstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5527 extent
[i
] = mpz_get_si (array
->shape
[i
]);
5532 continue_loop
= true;
5533 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5534 if (mask
&& mask
->rank
> 0)
5535 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5539 /* Loop over the array elements (and mask), keeping track of
5540 the indices to return. */
5541 while (continue_loop
)
5545 a
= array_ctor
->expr
;
5548 m
= mask_ctor
->expr
;
5549 ma
= m
->value
.logical
;
5550 mask_ctor
= gfc_constructor_next (mask_ctor
);
5555 if (ma
&& gfc_compare_expr (a
, value
, INTRINSIC_EQ
) == 0)
5557 for (i
= 0; i
<array
->rank
; i
++)
5562 array_ctor
= gfc_constructor_next (array_ctor
);
5564 } while (count
[0] != extent
[0]);
5568 /* When we get to the end of a dimension, reset it and increment
5569 the next dimension. */
5572 if (n
>= array
->rank
)
5574 continue_loop
= false;
5579 } while (count
[n
] == extent
[n
]);
5583 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5584 for (i
= 0; i
<array
->rank
; i
++)
5587 r_expr
= result_ctor
->expr
;
5588 mpz_set_si (r_expr
->value
.integer
, res
[i
] + 1);
5589 result_ctor
= gfc_constructor_next (result_ctor
);
5595 /* Simplify findloc to an array. Similar to
5596 simplify_minmaxloc_to_array. */
5599 simplify_findloc_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*value
,
5600 gfc_expr
*dim
, gfc_expr
*mask
, bool back_val
)
5603 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
5604 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
5605 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
5607 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
5608 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
5609 tmpstride
[GFC_MAX_DIMENSIONS
];
5611 /* Shortcut for constant .FALSE. MASK. */
5613 && mask
->expr_type
== EXPR_CONSTANT
5614 && !mask
->value
.logical
)
5617 /* Build an indexed table for array element expressions to minimize
5618 linked-list traversal. Masked elements are set to NULL. */
5619 gfc_array_size (array
, &size
);
5620 arraysize
= mpz_get_ui (size
);
5623 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
5625 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
5627 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
5628 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5630 for (i
= 0; i
< arraysize
; ++i
)
5632 arrayvec
[i
] = array_ctor
->expr
;
5633 array_ctor
= gfc_constructor_next (array_ctor
);
5637 if (!mask_ctor
->expr
->value
.logical
)
5640 mask_ctor
= gfc_constructor_next (mask_ctor
);
5644 /* Same for the result expression. */
5645 gfc_array_size (result
, &size
);
5646 resultsize
= mpz_get_ui (size
);
5649 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
5650 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5651 for (i
= 0; i
< resultsize
; ++i
)
5653 resultvec
[i
] = result_ctor
->expr
;
5654 result_ctor
= gfc_constructor_next (result_ctor
);
5657 gfc_extract_int (dim
, &dim_index
);
5659 dim_index
-= 1; /* Zero-base index. */
5663 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
5666 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
5669 dim_extent
= mpz_get_si (array
->shape
[i
]);
5670 dim_stride
= tmpstride
[i
];
5674 extent
[n
] = mpz_get_si (array
->shape
[i
]);
5675 sstride
[n
] = tmpstride
[i
];
5676 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
5680 done
= resultsize
<= 0;
5685 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
5687 if (*src
&& gfc_compare_expr (*src
, value
, INTRINSIC_EQ
) == 0)
5689 mpz_set_si ((*dest
)->value
.integer
, n
+ 1);
5700 while (!done
&& count
[n
] == extent
[n
])
5703 base
-= sstride
[n
] * extent
[n
];
5704 dest
-= dstride
[n
] * extent
[n
];
5707 if (n
< result
->rank
)
5709 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5710 times, we'd warn for the last iteration, because the
5711 array index will have already been incremented to the
5712 array sizes, and we can't tell that this must make
5713 the test against result->rank false, because ranks
5714 must not exceed GFC_MAX_DIMENSIONS. */
5715 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
5726 /* Place updated expression in result constructor. */
5727 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
5728 for (i
= 0; i
< resultsize
; ++i
)
5730 result_ctor
->expr
= resultvec
[i
];
5731 result_ctor
= gfc_constructor_next (result_ctor
);
5739 /* Simplify findloc. */
5742 gfc_simplify_findloc (gfc_expr
*array
, gfc_expr
*value
, gfc_expr
*dim
,
5743 gfc_expr
*mask
, gfc_expr
*kind
, gfc_expr
*back
)
5747 bool back_val
= false;
5749 if (!is_constant_array_expr (array
)
5750 || !gfc_is_constant_expr (dim
))
5753 if (! gfc_is_constant_expr (value
))
5757 && !is_constant_array_expr (mask
)
5758 && mask
->expr_type
!= EXPR_CONSTANT
)
5763 if (gfc_extract_int (kind
, &ikind
, -1))
5767 ikind
= gfc_default_integer_kind
;
5771 if (back
->expr_type
!= EXPR_CONSTANT
)
5774 back_val
= back
->value
.logical
;
5779 result
= transformational_result (array
, dim
, BT_INTEGER
,
5780 ikind
, &array
->where
);
5781 init_result_expr (result
, 0, array
);
5783 if (array
->rank
== 1)
5784 return simplify_findloc_to_scalar (result
, array
, value
, mask
,
5787 return simplify_findloc_to_array (result
, array
, value
, dim
, mask
,
5792 result
= new_array (BT_INTEGER
, ikind
, array
->rank
, &array
->where
);
5793 return simplify_findloc_nodim (result
, value
, array
, mask
, back_val
);
5799 gfc_simplify_maxexponent (gfc_expr
*x
)
5801 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5802 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5803 gfc_real_kinds
[i
].max_exponent
);
5808 gfc_simplify_minexponent (gfc_expr
*x
)
5810 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5811 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
5812 gfc_real_kinds
[i
].min_exponent
);
5817 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
5822 /* First check p. */
5823 if (p
->expr_type
!= EXPR_CONSTANT
)
5826 /* p shall not be 0. */
5830 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
5832 gfc_error ("Argument %qs of MOD at %L shall not be zero",
5834 return &gfc_bad_expr
;
5838 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
5840 gfc_error ("Argument %qs of MOD at %L shall not be zero",
5842 return &gfc_bad_expr
;
5846 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
5849 if (a
->expr_type
!= EXPR_CONSTANT
)
5852 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
5853 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
5855 if (a
->ts
.type
== BT_INTEGER
)
5856 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
5859 gfc_set_model_kind (kind
);
5860 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
5864 return range_check (result
, "MOD");
5869 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
5874 /* First check p. */
5875 if (p
->expr_type
!= EXPR_CONSTANT
)
5878 /* p shall not be 0. */
5882 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
5884 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
5886 return &gfc_bad_expr
;
5890 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
5892 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
5894 return &gfc_bad_expr
;
5898 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
5901 if (a
->expr_type
!= EXPR_CONSTANT
)
5904 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
5905 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
5907 if (a
->ts
.type
== BT_INTEGER
)
5908 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
5911 gfc_set_model_kind (kind
);
5912 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
5914 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
5916 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
5917 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
5921 mpfr_copysign (result
->value
.real
, result
->value
.real
,
5922 p
->value
.real
, GFC_RND_MODE
);
5925 return range_check (result
, "MODULO");
5930 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
5933 mp_exp_t emin
, emax
;
5936 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
5939 result
= gfc_copy_expr (x
);
5941 /* Save current values of emin and emax. */
5942 emin
= mpfr_get_emin ();
5943 emax
= mpfr_get_emax ();
5945 /* Set emin and emax for the current model number. */
5946 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
5947 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
5948 mpfr_get_prec(result
->value
.real
) + 1);
5949 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
5950 mpfr_check_range (result
->value
.real
, 0, GMP_RNDU
);
5952 if (mpfr_sgn (s
->value
.real
) > 0)
5954 mpfr_nextabove (result
->value
.real
);
5955 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
5959 mpfr_nextbelow (result
->value
.real
);
5960 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
5963 mpfr_set_emin (emin
);
5964 mpfr_set_emax (emax
);
5966 /* Only NaN can occur. Do not use range check as it gives an
5967 error for denormal numbers. */
5968 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
5970 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
5971 gfc_free_expr (result
);
5972 return &gfc_bad_expr
;
5980 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
5982 gfc_expr
*itrunc
, *result
;
5985 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
5987 return &gfc_bad_expr
;
5989 if (e
->expr_type
!= EXPR_CONSTANT
)
5992 itrunc
= gfc_copy_expr (e
);
5993 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
5995 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
5996 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
5998 gfc_free_expr (itrunc
);
6000 return range_check (result
, name
);
6005 gfc_simplify_new_line (gfc_expr
*e
)
6009 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
6010 result
->value
.character
.string
[0] = '\n';
6017 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
6019 return simplify_nint ("NINT", e
, k
);
6024 gfc_simplify_idnint (gfc_expr
*e
)
6026 return simplify_nint ("IDNINT", e
, NULL
);
6031 add_squared (gfc_expr
*result
, gfc_expr
*e
)
6035 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6036 gcc_assert (result
->ts
.type
== BT_REAL
6037 && result
->expr_type
== EXPR_CONSTANT
);
6039 gfc_set_model_kind (result
->ts
.kind
);
6041 mpfr_pow_ui (tmp
, e
->value
.real
, 2, GFC_RND_MODE
);
6042 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
6051 do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
6053 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
6054 gcc_assert (result
->ts
.type
== BT_REAL
6055 && result
->expr_type
== EXPR_CONSTANT
);
6057 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6058 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6064 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
6069 size_zero
= gfc_is_size_zero_array (e
);
6071 if (!(is_constant_array_expr (e
) || size_zero
)
6072 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
6075 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6076 init_result_expr (result
, 0, NULL
);
6081 if (!dim
|| e
->rank
== 1)
6083 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
6085 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
6088 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
6089 add_squared
, &do_sqrt
);
6096 gfc_simplify_not (gfc_expr
*e
)
6100 if (e
->expr_type
!= EXPR_CONSTANT
)
6103 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6104 mpz_com (result
->value
.integer
, e
->value
.integer
);
6106 return range_check (result
, "NOT");
6111 gfc_simplify_null (gfc_expr
*mold
)
6117 result
= gfc_copy_expr (mold
);
6118 result
->expr_type
= EXPR_NULL
;
6121 result
= gfc_get_null_expr (NULL
);
6128 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
6132 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6134 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6135 return &gfc_bad_expr
;
6138 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6141 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
6144 /* FIXME: gfc_current_locus is wrong. */
6145 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6146 &gfc_current_locus
);
6148 if (failed
&& failed
->value
.logical
!= 0)
6149 mpz_set_si (result
->value
.integer
, 0);
6151 mpz_set_si (result
->value
.integer
, 1);
6158 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
6163 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6166 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6171 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6172 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6173 return range_check (result
, "OR");
6176 return gfc_get_logical_expr (kind
, &x
->where
,
6177 x
->value
.logical
|| y
->value
.logical
);
6185 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
6188 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
6190 if (!is_constant_array_expr (array
)
6191 || !is_constant_array_expr (vector
)
6192 || (!gfc_is_constant_expr (mask
)
6193 && !is_constant_array_expr (mask
)))
6196 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
6197 if (array
->ts
.type
== BT_DERIVED
)
6198 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
6200 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
6201 vector_ctor
= vector
6202 ? gfc_constructor_first (vector
->value
.constructor
)
6205 if (mask
->expr_type
== EXPR_CONSTANT
6206 && mask
->value
.logical
)
6208 /* Copy all elements of ARRAY to RESULT. */
6211 gfc_constructor_append_expr (&result
->value
.constructor
,
6212 gfc_copy_expr (array_ctor
->expr
),
6215 array_ctor
= gfc_constructor_next (array_ctor
);
6216 vector_ctor
= gfc_constructor_next (vector_ctor
);
6219 else if (mask
->expr_type
== EXPR_ARRAY
)
6221 /* Copy only those elements of ARRAY to RESULT whose
6222 MASK equals .TRUE.. */
6223 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6226 if (mask_ctor
->expr
->value
.logical
)
6228 gfc_constructor_append_expr (&result
->value
.constructor
,
6229 gfc_copy_expr (array_ctor
->expr
),
6231 vector_ctor
= gfc_constructor_next (vector_ctor
);
6234 array_ctor
= gfc_constructor_next (array_ctor
);
6235 mask_ctor
= gfc_constructor_next (mask_ctor
);
6239 /* Append any left-over elements from VECTOR to RESULT. */
6242 gfc_constructor_append_expr (&result
->value
.constructor
,
6243 gfc_copy_expr (vector_ctor
->expr
),
6245 vector_ctor
= gfc_constructor_next (vector_ctor
);
6248 result
->shape
= gfc_get_shape (1);
6249 gfc_array_size (result
, &result
->shape
[0]);
6251 if (array
->ts
.type
== BT_CHARACTER
)
6252 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
6259 do_xor (gfc_expr
*result
, gfc_expr
*e
)
6261 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
6262 gcc_assert (result
->ts
.type
== BT_LOGICAL
6263 && result
->expr_type
== EXPR_CONSTANT
);
6265 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
6272 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
6274 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
6279 gfc_simplify_popcnt (gfc_expr
*e
)
6284 if (e
->expr_type
!= EXPR_CONSTANT
)
6287 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6289 /* Convert argument to unsigned, then count the '1' bits. */
6290 mpz_init_set (x
, e
->value
.integer
);
6291 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
6292 res
= mpz_popcount (x
);
6295 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
6300 gfc_simplify_poppar (gfc_expr
*e
)
6305 if (e
->expr_type
!= EXPR_CONSTANT
)
6308 popcnt
= gfc_simplify_popcnt (e
);
6309 gcc_assert (popcnt
);
6311 bool fail
= gfc_extract_int (popcnt
, &i
);
6314 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
6319 gfc_simplify_precision (gfc_expr
*e
)
6321 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6322 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
6323 gfc_real_kinds
[i
].precision
);
6328 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6330 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
6335 gfc_simplify_radix (gfc_expr
*e
)
6338 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6343 i
= gfc_integer_kinds
[i
].radix
;
6347 i
= gfc_real_kinds
[i
].radix
;
6354 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6359 gfc_simplify_range (gfc_expr
*e
)
6362 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6367 i
= gfc_integer_kinds
[i
].range
;
6372 i
= gfc_real_kinds
[i
].range
;
6379 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
6384 gfc_simplify_rank (gfc_expr
*e
)
6390 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
6395 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
6397 gfc_expr
*result
= NULL
;
6400 if (e
->ts
.type
== BT_COMPLEX
)
6401 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
6403 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
6406 return &gfc_bad_expr
;
6408 if (e
->expr_type
!= EXPR_CONSTANT
)
6411 if (convert_boz (e
, kind
) == &gfc_bad_expr
)
6412 return &gfc_bad_expr
;
6414 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
6415 if (result
== &gfc_bad_expr
)
6416 return &gfc_bad_expr
;
6418 return range_check (result
, "REAL");
6423 gfc_simplify_realpart (gfc_expr
*e
)
6427 if (e
->expr_type
!= EXPR_CONSTANT
)
6430 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6431 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
6433 return range_check (result
, "REALPART");
6437 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
6442 bool have_length
= false;
6444 /* If NCOPIES isn't a constant, there's nothing we can do. */
6445 if (n
->expr_type
!= EXPR_CONSTANT
)
6448 /* If NCOPIES is negative, it's an error. */
6449 if (mpz_sgn (n
->value
.integer
) < 0)
6451 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6453 return &gfc_bad_expr
;
6456 /* If we don't know the character length, we can do no more. */
6457 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
6458 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6460 len
= gfc_mpz_get_hwi (e
->ts
.u
.cl
->length
->value
.integer
);
6463 else if (e
->expr_type
== EXPR_CONSTANT
6464 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
6466 len
= e
->value
.character
.length
;
6471 /* If the source length is 0, any value of NCOPIES is valid
6472 and everything behaves as if NCOPIES == 0. */
6475 mpz_set_ui (ncopies
, 0);
6477 mpz_set (ncopies
, n
->value
.integer
);
6479 /* Check that NCOPIES isn't too large. */
6485 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6487 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
6491 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
6492 e
->ts
.u
.cl
->length
->value
.integer
);
6497 gfc_mpz_set_hwi (mlen
, len
);
6498 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
6502 /* The check itself. */
6503 if (mpz_cmp (ncopies
, max
) > 0)
6506 mpz_clear (ncopies
);
6507 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6509 return &gfc_bad_expr
;
6514 mpz_clear (ncopies
);
6516 /* For further simplification, we need the character string to be
6518 if (e
->expr_type
!= EXPR_CONSTANT
)
6523 (e
->ts
.u
.cl
->length
&&
6524 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
) != 0))
6526 bool fail
= gfc_extract_hwi (n
, &ncop
);
6533 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
6535 len
= e
->value
.character
.length
;
6536 gfc_charlen_t nlen
= ncop
* len
;
6538 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6539 (2**28 elements * 4 bytes (wide chars) per element) defer to
6540 runtime instead of consuming (unbounded) memory and CPU at
6542 if (nlen
> 268435456)
6544 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6545 " deferred to runtime, expect bugs", &e
->where
);
6549 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
6550 for (size_t i
= 0; i
< (size_t) ncop
; i
++)
6551 for (size_t j
= 0; j
< (size_t) len
; j
++)
6552 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
6554 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
6559 /* This one is a bear, but mainly has to do with shuffling elements. */
6562 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
6563 gfc_expr
*pad
, gfc_expr
*order_exp
)
6565 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
6566 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
6570 gfc_expr
*e
, *result
;
6572 /* Check that argument expression types are OK. */
6573 if (!is_constant_array_expr (source
)
6574 || !is_constant_array_expr (shape_exp
)
6575 || !is_constant_array_expr (pad
)
6576 || !is_constant_array_expr (order_exp
))
6579 if (source
->shape
== NULL
)
6582 /* Proceed with simplification, unpacking the array. */
6589 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
6593 gfc_extract_int (e
, &shape
[rank
]);
6595 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
6596 gcc_assert (shape
[rank
] >= 0);
6601 gcc_assert (rank
> 0);
6603 /* Now unpack the order array if present. */
6604 if (order_exp
== NULL
)
6606 for (i
= 0; i
< rank
; i
++)
6611 for (i
= 0; i
< rank
; i
++)
6614 for (i
= 0; i
< rank
; i
++)
6616 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
6619 gfc_extract_int (e
, &order
[i
]);
6621 gcc_assert (order
[i
] >= 1 && order
[i
] <= rank
);
6623 gcc_assert (x
[order
[i
]] == 0);
6628 /* Count the elements in the source and padding arrays. */
6633 gfc_array_size (pad
, &size
);
6634 npad
= mpz_get_ui (size
);
6638 gfc_array_size (source
, &size
);
6639 nsource
= mpz_get_ui (size
);
6642 /* If it weren't for that pesky permutation we could just loop
6643 through the source and round out any shortage with pad elements.
6644 But no, someone just had to have the compiler do something the
6645 user should be doing. */
6647 for (i
= 0; i
< rank
; i
++)
6650 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6652 if (source
->ts
.type
== BT_DERIVED
)
6653 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6654 result
->rank
= rank
;
6655 result
->shape
= gfc_get_shape (rank
);
6656 for (i
= 0; i
< rank
; i
++)
6657 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
6659 while (nsource
> 0 || npad
> 0)
6661 /* Figure out which element to extract. */
6662 mpz_set_ui (index
, 0);
6664 for (i
= rank
- 1; i
>= 0; i
--)
6666 mpz_add_ui (index
, index
, x
[order
[i
]]);
6668 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
6671 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
6672 gfc_internal_error ("Reshaped array too large at %C");
6674 j
= mpz_get_ui (index
);
6677 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
6687 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
6691 gfc_constructor_append_expr (&result
->value
.constructor
,
6692 gfc_copy_expr (e
), &e
->where
);
6694 /* Calculate the next element. */
6698 if (++x
[i
] < shape
[i
])
6714 gfc_simplify_rrspacing (gfc_expr
*x
)
6720 if (x
->expr_type
!= EXPR_CONSTANT
)
6723 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
6725 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
6727 /* RRSPACING(+/- 0.0) = 0.0 */
6728 if (mpfr_zero_p (x
->value
.real
))
6730 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
6734 /* RRSPACING(inf) = NaN */
6735 if (mpfr_inf_p (x
->value
.real
))
6737 mpfr_set_nan (result
->value
.real
);
6741 /* RRSPACING(NaN) = same NaN */
6742 if (mpfr_nan_p (x
->value
.real
))
6744 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6748 /* | x * 2**(-e) | * 2**p. */
6749 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6750 e
= - (long int) mpfr_get_exp (x
->value
.real
);
6751 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
6753 p
= (long int) gfc_real_kinds
[i
].digits
;
6754 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
6756 return range_check (result
, "RRSPACING");
6761 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
6763 int k
, neg_flag
, power
, exp_range
;
6764 mpfr_t scale
, radix
;
6767 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
6770 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
6772 if (mpfr_zero_p (x
->value
.real
))
6774 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
6778 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
6780 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
6782 /* This check filters out values of i that would overflow an int. */
6783 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
6784 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
6786 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
6787 gfc_free_expr (result
);
6788 return &gfc_bad_expr
;
6791 /* Compute scale = radix ** power. */
6792 power
= mpz_get_si (i
->value
.integer
);
6802 gfc_set_model_kind (x
->ts
.kind
);
6805 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
6806 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
6809 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
6811 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
6813 mpfr_clears (scale
, radix
, NULL
);
6815 return range_check (result
, "SCALE");
6819 /* Variants of strspn and strcspn that operate on wide characters. */
6822 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
6825 const gfc_char_t
*c
;
6829 for (c
= s2
; *c
; c
++)
6843 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
6846 const gfc_char_t
*c
;
6850 for (c
= s2
; *c
; c
++)
6865 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
6870 size_t indx
, len
, lenc
;
6871 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
6874 return &gfc_bad_expr
;
6876 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
6877 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
6880 if (b
!= NULL
&& b
->value
.logical
!= 0)
6885 len
= e
->value
.character
.length
;
6886 lenc
= c
->value
.character
.length
;
6888 if (len
== 0 || lenc
== 0)
6896 indx
= wide_strcspn (e
->value
.character
.string
,
6897 c
->value
.character
.string
) + 1;
6904 for (indx
= len
; indx
> 0; indx
--)
6906 for (i
= 0; i
< lenc
; i
++)
6908 if (c
->value
.character
.string
[i
]
6909 == e
->value
.character
.string
[indx
- 1])
6918 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
6919 return range_check (result
, "SCAN");
6924 gfc_simplify_selected_char_kind (gfc_expr
*e
)
6928 if (e
->expr_type
!= EXPR_CONSTANT
)
6931 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
6932 || gfc_compare_with_Cstring (e
, "default", false) == 0)
6934 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
6939 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
6944 gfc_simplify_selected_int_kind (gfc_expr
*e
)
6948 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
))
6953 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
6954 if (gfc_integer_kinds
[i
].range
>= range
6955 && gfc_integer_kinds
[i
].kind
< kind
)
6956 kind
= gfc_integer_kinds
[i
].kind
;
6958 if (kind
== INT_MAX
)
6961 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
6966 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
6968 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
6970 locus
*loc
= &gfc_current_locus
;
6976 if (p
->expr_type
!= EXPR_CONSTANT
6977 || gfc_extract_int (p
, &precision
))
6986 if (q
->expr_type
!= EXPR_CONSTANT
6987 || gfc_extract_int (q
, &range
))
6998 if (rdx
->expr_type
!= EXPR_CONSTANT
6999 || gfc_extract_int (rdx
, &radix
))
7007 found_precision
= 0;
7011 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
7013 if (gfc_real_kinds
[i
].precision
>= precision
)
7014 found_precision
= 1;
7016 if (gfc_real_kinds
[i
].range
>= range
)
7019 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7022 if (gfc_real_kinds
[i
].precision
>= precision
7023 && gfc_real_kinds
[i
].range
>= range
7024 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
7025 && gfc_real_kinds
[i
].kind
< kind
)
7026 kind
= gfc_real_kinds
[i
].kind
;
7029 if (kind
== INT_MAX
)
7031 if (found_radix
&& found_range
&& !found_precision
)
7033 else if (found_radix
&& found_precision
&& !found_range
)
7035 else if (found_radix
&& !found_precision
&& !found_range
)
7037 else if (found_radix
)
7043 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
7048 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
7051 mpfr_t exp
, absv
, log2
, pow2
, frac
;
7054 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
7057 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7059 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7060 SET_EXPONENT (NaN) = same NaN */
7061 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
7063 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7067 /* SET_EXPONENT (inf) = NaN */
7068 if (mpfr_inf_p (x
->value
.real
))
7070 mpfr_set_nan (result
->value
.real
);
7074 gfc_set_model_kind (x
->ts
.kind
);
7081 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
7082 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
7084 mpfr_trunc (log2
, log2
);
7085 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
7087 /* Old exponent value, and fraction. */
7088 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
7090 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
7093 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
7094 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
7096 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
7098 return range_check (result
, "SET_EXPONENT");
7103 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
7105 mpz_t shape
[GFC_MAX_DIMENSIONS
];
7106 gfc_expr
*result
, *e
, *f
;
7110 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
7112 if (source
->rank
== -1)
7115 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
7117 if (source
->rank
== 0)
7120 if (source
->expr_type
== EXPR_VARIABLE
)
7122 ar
= gfc_find_array_ref (source
);
7123 t
= gfc_array_ref_shape (ar
, shape
);
7125 else if (source
->shape
)
7128 for (n
= 0; n
< source
->rank
; n
++)
7130 mpz_init (shape
[n
]);
7131 mpz_set (shape
[n
], source
->shape
[n
]);
7137 for (n
= 0; n
< source
->rank
; n
++)
7139 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
7142 mpz_set (e
->value
.integer
, shape
[n
]);
7145 mpz_set_ui (e
->value
.integer
, n
+ 1);
7147 f
= simplify_size (source
, e
, k
);
7151 gfc_free_expr (result
);
7158 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
7160 gfc_free_expr (result
);
7162 gfc_clear_shape (shape
, source
->rank
);
7163 return &gfc_bad_expr
;
7166 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
7170 gfc_clear_shape (shape
, source
->rank
);
7177 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
7180 gfc_expr
*return_value
;
7183 /* For unary operations, the size of the result is given by the size
7184 of the operand. For binary ones, it's the size of the first operand
7185 unless it is scalar, then it is the size of the second. */
7186 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
7188 gfc_expr
* replacement
;
7189 gfc_expr
* simplified
;
7191 switch (array
->value
.op
.op
)
7193 /* Unary operations. */
7195 case INTRINSIC_UPLUS
:
7196 case INTRINSIC_UMINUS
:
7197 case INTRINSIC_PARENTHESES
:
7198 replacement
= array
->value
.op
.op1
;
7201 /* Binary operations. If any one of the operands is scalar, take
7202 the other one's size. If both of them are arrays, it does not
7203 matter -- try to find one with known shape, if possible. */
7205 if (array
->value
.op
.op1
->rank
== 0)
7206 replacement
= array
->value
.op
.op2
;
7207 else if (array
->value
.op
.op2
->rank
== 0)
7208 replacement
= array
->value
.op
.op1
;
7211 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
7215 replacement
= array
->value
.op
.op2
;
7220 /* Try to reduce it directly if possible. */
7221 simplified
= simplify_size (replacement
, dim
, k
);
7223 /* Otherwise, we build a new SIZE call. This is hopefully at least
7224 simpler than the original one. */
7227 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
7228 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
7229 GFC_ISYM_SIZE
, "size",
7231 gfc_copy_expr (replacement
),
7232 gfc_copy_expr (dim
),
7240 if (!gfc_array_size (array
, &size
))
7245 if (dim
->expr_type
!= EXPR_CONSTANT
)
7248 d
= mpz_get_ui (dim
->value
.integer
) - 1;
7249 if (!gfc_array_dimen_size (array
, d
, &size
))
7253 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
7254 mpz_set (return_value
->value
.integer
, size
);
7257 return return_value
;
7262 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
7265 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
7268 return &gfc_bad_expr
;
7270 result
= simplify_size (array
, dim
, k
);
7271 if (result
== NULL
|| result
== &gfc_bad_expr
)
7274 return range_check (result
, "SIZE");
7278 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
7279 multiplied by the array size. */
7282 gfc_simplify_sizeof (gfc_expr
*x
)
7284 gfc_expr
*result
= NULL
;
7287 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7290 if (x
->ts
.type
== BT_CHARACTER
7291 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7292 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7295 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
7296 && !gfc_array_size (x
, &array_size
))
7299 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
7301 mpz_set_si (result
->value
.integer
, gfc_target_expr_size (x
));
7307 /* STORAGE_SIZE returns the size in bits of a single array element. */
7310 gfc_simplify_storage_size (gfc_expr
*x
,
7313 gfc_expr
*result
= NULL
;
7316 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
7319 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
7320 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
7321 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
7324 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
7326 return &gfc_bad_expr
;
7328 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
7330 mpz_set_si (result
->value
.integer
, gfc_element_size (x
));
7331 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
7333 return range_check (result
, "STORAGE_SIZE");
7338 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
7342 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
7345 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7350 mpz_abs (result
->value
.integer
, x
->value
.integer
);
7351 if (mpz_sgn (y
->value
.integer
) < 0)
7352 mpz_neg (result
->value
.integer
, result
->value
.integer
);
7357 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
7360 mpfr_setsign (result
->value
.real
, x
->value
.real
,
7361 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
7365 gfc_internal_error ("Bad type in gfc_simplify_sign");
7373 gfc_simplify_sin (gfc_expr
*x
)
7377 if (x
->expr_type
!= EXPR_CONSTANT
)
7380 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7385 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7389 gfc_set_model (x
->value
.real
);
7390 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7394 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
7397 return range_check (result
, "SIN");
7402 gfc_simplify_sinh (gfc_expr
*x
)
7406 if (x
->expr_type
!= EXPR_CONSTANT
)
7409 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7414 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7418 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7425 return range_check (result
, "SINH");
7429 /* The argument is always a double precision real that is converted to
7430 single precision. TODO: Rounding! */
7433 gfc_simplify_sngl (gfc_expr
*a
)
7437 if (a
->expr_type
!= EXPR_CONSTANT
)
7440 result
= gfc_real2real (a
, gfc_default_real_kind
);
7441 return range_check (result
, "SNGL");
7446 gfc_simplify_spacing (gfc_expr
*x
)
7452 if (x
->expr_type
!= EXPR_CONSTANT
)
7455 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
7456 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
7458 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
7459 if (mpfr_zero_p (x
->value
.real
))
7461 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
7465 /* SPACING(inf) = NaN */
7466 if (mpfr_inf_p (x
->value
.real
))
7468 mpfr_set_nan (result
->value
.real
);
7472 /* SPACING(NaN) = same NaN */
7473 if (mpfr_nan_p (x
->value
.real
))
7475 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7479 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
7480 are the radix, exponent of x, and precision. This excludes the
7481 possibility of subnormal numbers. Fortran 2003 states the result is
7482 b**max(e - p, emin - 1). */
7484 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
7485 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
7486 en
= en
> ep
? en
: ep
;
7488 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
7489 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
7491 return range_check (result
, "SPACING");
7496 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
7498 gfc_expr
*result
= NULL
;
7499 int nelem
, i
, j
, dim
, ncopies
;
7502 if ((!gfc_is_constant_expr (source
)
7503 && !is_constant_array_expr (source
))
7504 || !gfc_is_constant_expr (dim_expr
)
7505 || !gfc_is_constant_expr (ncopies_expr
))
7508 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
7509 gfc_extract_int (dim_expr
, &dim
);
7510 dim
-= 1; /* zero-base DIM */
7512 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
7513 gfc_extract_int (ncopies_expr
, &ncopies
);
7514 ncopies
= MAX (ncopies
, 0);
7516 /* Do not allow the array size to exceed the limit for an array
7518 if (source
->expr_type
== EXPR_ARRAY
)
7520 if (!gfc_array_size (source
, &size
))
7521 gfc_internal_error ("Failure getting length of a constant array.");
7524 mpz_init_set_ui (size
, 1);
7526 nelem
= mpz_get_si (size
) * ncopies
;
7527 if (nelem
> flag_max_array_constructor
)
7529 if (gfc_current_ns
->sym_root
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
7531 gfc_error ("The number of elements (%d) in the array constructor "
7532 "at %L requires an increase of the allowed %d upper "
7533 "limit. See %<-fmax-array-constructor%> option.",
7534 nelem
, &source
->where
, flag_max_array_constructor
);
7535 return &gfc_bad_expr
;
7541 if (source
->expr_type
== EXPR_CONSTANT
)
7543 gcc_assert (dim
== 0);
7545 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7547 if (source
->ts
.type
== BT_DERIVED
)
7548 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7550 result
->shape
= gfc_get_shape (result
->rank
);
7551 mpz_init_set_si (result
->shape
[0], ncopies
);
7553 for (i
= 0; i
< ncopies
; ++i
)
7554 gfc_constructor_append_expr (&result
->value
.constructor
,
7555 gfc_copy_expr (source
), NULL
);
7557 else if (source
->expr_type
== EXPR_ARRAY
)
7559 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
7560 gfc_constructor
*source_ctor
;
7562 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
7563 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
7565 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
7567 if (source
->ts
.type
== BT_DERIVED
)
7568 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
7569 result
->rank
= source
->rank
+ 1;
7570 result
->shape
= gfc_get_shape (result
->rank
);
7572 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
7575 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
7577 mpz_init_set_si (result
->shape
[i
], ncopies
);
7579 extent
[i
] = mpz_get_si (result
->shape
[i
]);
7580 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
7584 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
7585 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
7587 for (i
= 0; i
< ncopies
; ++i
)
7588 gfc_constructor_insert_expr (&result
->value
.constructor
,
7589 gfc_copy_expr (source_ctor
->expr
),
7590 NULL
, offset
+ i
* rstride
[dim
]);
7592 offset
+= (dim
== 0 ? ncopies
: 1);
7597 gfc_error ("Simplification of SPREAD at %C not yet implemented");
7598 return &gfc_bad_expr
;
7601 if (source
->ts
.type
== BT_CHARACTER
)
7602 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
7609 gfc_simplify_sqrt (gfc_expr
*e
)
7611 gfc_expr
*result
= NULL
;
7613 if (e
->expr_type
!= EXPR_CONSTANT
)
7619 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
7621 gfc_error ("Argument of SQRT at %L has a negative value",
7623 return &gfc_bad_expr
;
7625 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7626 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
7630 gfc_set_model (e
->value
.real
);
7632 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
7633 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
7637 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
7640 return range_check (result
, "SQRT");
7645 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
7647 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
7652 gfc_simplify_cotan (gfc_expr
*x
)
7657 if (x
->expr_type
!= EXPR_CONSTANT
)
7660 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7665 mpfr_cot (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7669 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
7670 val
= &result
->value
.complex;
7671 mpc_init2 (swp
, mpfr_get_default_prec ());
7672 mpc_cos (swp
, x
->value
.complex, GFC_MPC_RND_MODE
);
7673 mpc_sin (*val
, x
->value
.complex, GFC_MPC_RND_MODE
);
7674 mpc_div (*val
, swp
, *val
, GFC_MPC_RND_MODE
);
7682 return range_check (result
, "COTAN");
7687 gfc_simplify_tan (gfc_expr
*x
)
7691 if (x
->expr_type
!= EXPR_CONSTANT
)
7694 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7699 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7703 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7710 return range_check (result
, "TAN");
7715 gfc_simplify_tanh (gfc_expr
*x
)
7719 if (x
->expr_type
!= EXPR_CONSTANT
)
7722 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
7727 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
7731 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
7738 return range_check (result
, "TANH");
7743 gfc_simplify_tiny (gfc_expr
*e
)
7748 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
7750 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
7751 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
7758 gfc_simplify_trailz (gfc_expr
*e
)
7760 unsigned long tz
, bs
;
7763 if (e
->expr_type
!= EXPR_CONSTANT
)
7766 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
7767 bs
= gfc_integer_kinds
[i
].bit_size
;
7768 tz
= mpz_scan1 (e
->value
.integer
, 0);
7770 return gfc_get_int_expr (gfc_default_integer_kind
,
7771 &e
->where
, MIN (tz
, bs
));
7776 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
7779 gfc_expr
*mold_element
;
7784 unsigned char *buffer
;
7785 size_t result_length
;
7787 if (!gfc_is_constant_expr (source
) || !gfc_is_constant_expr (size
))
7790 if (!gfc_resolve_expr (mold
))
7792 if (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
7795 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
7796 &result_size
, &result_length
))
7799 /* Calculate the size of the source. */
7800 if (source
->expr_type
== EXPR_ARRAY
&& !gfc_array_size (source
, &tmp
))
7801 gfc_internal_error ("Failure getting length of a constant array.");
7803 /* Create an empty new expression with the appropriate characteristics. */
7804 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
7806 result
->ts
= mold
->ts
;
7808 mold_element
= (mold
->expr_type
== EXPR_ARRAY
&& mold
->value
.constructor
)
7809 ? gfc_constructor_first (mold
->value
.constructor
)->expr
7812 /* Set result character length, if needed. Note that this needs to be
7813 set even for array expressions, in order to pass this information into
7814 gfc_target_interpret_expr. */
7815 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
7816 result
->value
.character
.length
= mold_element
->value
.character
.length
;
7818 /* Set the number of elements in the result, and determine its size. */
7820 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
7822 result
->expr_type
= EXPR_ARRAY
;
7824 result
->shape
= gfc_get_shape (1);
7825 mpz_init_set_ui (result
->shape
[0], result_length
);
7830 /* Allocate the buffer to store the binary version of the source. */
7831 buffer_size
= MAX (source_size
, result_size
);
7832 buffer
= (unsigned char*)alloca (buffer_size
);
7833 memset (buffer
, 0, buffer_size
);
7835 /* Now write source to the buffer. */
7836 gfc_target_encode_expr (source
, buffer
, buffer_size
);
7838 /* And read the buffer back into the new expression. */
7839 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
7846 gfc_simplify_transpose (gfc_expr
*matrix
)
7848 int row
, matrix_rows
, col
, matrix_cols
;
7851 if (!is_constant_array_expr (matrix
))
7854 gcc_assert (matrix
->rank
== 2);
7856 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
7859 result
->shape
= gfc_get_shape (result
->rank
);
7860 mpz_set (result
->shape
[0], matrix
->shape
[1]);
7861 mpz_set (result
->shape
[1], matrix
->shape
[0]);
7863 if (matrix
->ts
.type
== BT_CHARACTER
)
7864 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
7865 else if (matrix
->ts
.type
== BT_DERIVED
)
7866 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
7868 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
7869 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
7870 for (row
= 0; row
< matrix_rows
; ++row
)
7871 for (col
= 0; col
< matrix_cols
; ++col
)
7873 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
7874 col
* matrix_rows
+ row
);
7875 gfc_constructor_insert_expr (&result
->value
.constructor
,
7876 gfc_copy_expr (e
), &matrix
->where
,
7877 row
* matrix_cols
+ col
);
7885 gfc_simplify_trim (gfc_expr
*e
)
7888 int count
, i
, len
, lentrim
;
7890 if (e
->expr_type
!= EXPR_CONSTANT
)
7893 len
= e
->value
.character
.length
;
7894 for (count
= 0, i
= 1; i
<= len
; ++i
)
7896 if (e
->value
.character
.string
[len
- i
] == ' ')
7902 lentrim
= len
- count
;
7904 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
7905 for (i
= 0; i
< lentrim
; i
++)
7906 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
7913 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
7918 gfc_constructor
*sub_cons
;
7922 if (!is_constant_array_expr (sub
))
7925 /* Follow any component references. */
7926 as
= coarray
->symtree
->n
.sym
->as
;
7927 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
7928 if (ref
->type
== REF_COMPONENT
)
7931 if (as
->type
== AS_DEFERRED
)
7934 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
7935 the cosubscript addresses the first image. */
7937 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
7940 for (d
= 1; d
<= as
->corank
; d
++)
7945 gcc_assert (sub_cons
!= NULL
);
7947 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
7949 if (ca_bound
== NULL
)
7952 if (ca_bound
== &gfc_bad_expr
)
7955 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
7959 gfc_free_expr (ca_bound
);
7960 sub_cons
= gfc_constructor_next (sub_cons
);
7964 first_image
= false;
7968 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
7969 "SUB has %ld and COARRAY lower bound is %ld)",
7971 mpz_get_si (sub_cons
->expr
->value
.integer
),
7972 mpz_get_si (ca_bound
->value
.integer
));
7973 gfc_free_expr (ca_bound
);
7974 return &gfc_bad_expr
;
7977 gfc_free_expr (ca_bound
);
7979 /* Check whether upperbound is valid for the multi-images case. */
7982 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
7984 if (ca_bound
== &gfc_bad_expr
)
7987 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
7988 && mpz_cmp (ca_bound
->value
.integer
,
7989 sub_cons
->expr
->value
.integer
) < 0)
7991 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
7992 "SUB has %ld and COARRAY upper bound is %ld)",
7994 mpz_get_si (sub_cons
->expr
->value
.integer
),
7995 mpz_get_si (ca_bound
->value
.integer
));
7996 gfc_free_expr (ca_bound
);
7997 return &gfc_bad_expr
;
8001 gfc_free_expr (ca_bound
);
8004 sub_cons
= gfc_constructor_next (sub_cons
);
8007 gcc_assert (sub_cons
== NULL
);
8009 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
8012 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8013 &gfc_current_locus
);
8015 mpz_set_si (result
->value
.integer
, 1);
8017 mpz_set_si (result
->value
.integer
, 0);
8023 gfc_simplify_image_status (gfc_expr
*image
, gfc_expr
*team ATTRIBUTE_UNUSED
)
8025 if (flag_coarray
== GFC_FCOARRAY_NONE
)
8027 gfc_current_locus
= *gfc_current_intrinsic_where
;
8028 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
8029 return &gfc_bad_expr
;
8032 /* Simplification is possible for fcoarray = single only. For all other modes
8033 the result depends on runtime conditions. */
8034 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8037 if (gfc_is_constant_expr (image
))
8040 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8042 if (mpz_get_si (image
->value
.integer
) == 1)
8043 mpz_set_si (result
->value
.integer
, 0);
8045 mpz_set_si (result
->value
.integer
, GFC_STAT_STOPPED_IMAGE
);
8054 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
8055 gfc_expr
*distance ATTRIBUTE_UNUSED
)
8057 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
8060 /* If no coarray argument has been passed or when the first argument
8061 is actually a distance argment. */
8062 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
8065 /* FIXME: gfc_current_locus is wrong. */
8066 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
8067 &gfc_current_locus
);
8068 mpz_set_si (result
->value
.integer
, 1);
8072 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
8073 return simplify_cobound (coarray
, dim
, NULL
, 0);
8078 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8080 return simplify_bound (array
, dim
, kind
, 1);
8084 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
8086 return simplify_cobound (array
, dim
, kind
, 1);
8091 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
8093 gfc_expr
*result
, *e
;
8094 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
8096 if (!is_constant_array_expr (vector
)
8097 || !is_constant_array_expr (mask
)
8098 || (!gfc_is_constant_expr (field
)
8099 && !is_constant_array_expr (field
)))
8102 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
8104 if (vector
->ts
.type
== BT_DERIVED
)
8105 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
8106 result
->rank
= mask
->rank
;
8107 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
8109 if (vector
->ts
.type
== BT_CHARACTER
)
8110 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
8112 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
8113 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
8115 = field
->expr_type
== EXPR_ARRAY
8116 ? gfc_constructor_first (field
->value
.constructor
)
8121 if (mask_ctor
->expr
->value
.logical
)
8123 gcc_assert (vector_ctor
);
8124 e
= gfc_copy_expr (vector_ctor
->expr
);
8125 vector_ctor
= gfc_constructor_next (vector_ctor
);
8127 else if (field
->expr_type
== EXPR_ARRAY
)
8128 e
= gfc_copy_expr (field_ctor
->expr
);
8130 e
= gfc_copy_expr (field
);
8132 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
8134 mask_ctor
= gfc_constructor_next (mask_ctor
);
8135 field_ctor
= gfc_constructor_next (field_ctor
);
8143 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
8147 size_t index
, len
, lenset
;
8149 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
8152 return &gfc_bad_expr
;
8154 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
8155 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
8158 if (b
!= NULL
&& b
->value
.logical
!= 0)
8163 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
8165 len
= s
->value
.character
.length
;
8166 lenset
= set
->value
.character
.length
;
8170 mpz_set_ui (result
->value
.integer
, 0);
8178 mpz_set_ui (result
->value
.integer
, 1);
8182 index
= wide_strspn (s
->value
.character
.string
,
8183 set
->value
.character
.string
) + 1;
8192 mpz_set_ui (result
->value
.integer
, len
);
8195 for (index
= len
; index
> 0; index
--)
8197 for (i
= 0; i
< lenset
; i
++)
8199 if (s
->value
.character
.string
[index
- 1]
8200 == set
->value
.character
.string
[i
])
8208 mpz_set_ui (result
->value
.integer
, index
);
8214 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
8219 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
8222 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
8227 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
8228 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
8229 return range_check (result
, "XOR");
8232 return gfc_get_logical_expr (kind
, &x
->where
,
8233 (x
->value
.logical
&& !y
->value
.logical
)
8234 || (!x
->value
.logical
&& y
->value
.logical
));
8242 /****************** Constant simplification *****************/
8244 /* Master function to convert one constant to another. While this is
8245 used as a simplification function, it requires the destination type
8246 and kind information which is supplied by a special case in
8250 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
8252 gfc_expr
*result
, *(*f
) (gfc_expr
*, int);
8253 gfc_constructor
*c
, *t
;
8267 f
= gfc_int2complex
;
8287 f
= gfc_real2complex
;
8298 f
= gfc_complex2int
;
8301 f
= gfc_complex2real
;
8304 f
= gfc_complex2complex
;
8330 f
= gfc_hollerith2int
;
8334 f
= gfc_hollerith2real
;
8338 f
= gfc_hollerith2complex
;
8342 f
= gfc_hollerith2character
;
8346 f
= gfc_hollerith2logical
;
8355 if (type
== BT_CHARACTER
)
8356 f
= gfc_character2character
;
8363 return &gfc_bad_expr
;
8368 switch (e
->expr_type
)
8371 result
= f (e
, kind
);
8373 return &gfc_bad_expr
;
8377 if (!gfc_is_constant_expr (e
))
8380 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8381 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8382 result
->rank
= e
->rank
;
8384 for (c
= gfc_constructor_first (e
->value
.constructor
);
8385 c
; c
= gfc_constructor_next (c
))
8388 if (c
->iterator
== NULL
)
8390 if (c
->expr
->expr_type
== EXPR_ARRAY
)
8391 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8393 tmp
= f (c
->expr
, kind
);
8396 tmp
= gfc_convert_constant (c
->expr
, type
, kind
);
8398 if (tmp
== NULL
|| tmp
== &gfc_bad_expr
)
8400 gfc_free_expr (result
);
8404 t
= gfc_constructor_append_expr (&result
->value
.constructor
,
8407 t
->iterator
= gfc_copy_iterator (c
->iterator
);
8420 /* Function for converting character constants. */
8422 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
8427 if (!gfc_is_constant_expr (e
))
8430 if (e
->expr_type
== EXPR_CONSTANT
)
8432 /* Simple case of a scalar. */
8433 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
8435 return &gfc_bad_expr
;
8437 result
->value
.character
.length
= e
->value
.character
.length
;
8438 result
->value
.character
.string
8439 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
8440 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
8441 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
8443 /* Check we only have values representable in the destination kind. */
8444 for (i
= 0; i
< result
->value
.character
.length
; i
++)
8445 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
8448 gfc_error ("Character %qs in string at %L cannot be converted "
8449 "into character kind %d",
8450 gfc_print_wide_char (result
->value
.character
.string
[i
]),
8452 gfc_free_expr (result
);
8453 return &gfc_bad_expr
;
8458 else if (e
->expr_type
== EXPR_ARRAY
)
8460 /* For an array constructor, we convert each constructor element. */
8463 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
8464 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
8465 result
->rank
= e
->rank
;
8466 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
8468 for (c
= gfc_constructor_first (e
->value
.constructor
);
8469 c
; c
= gfc_constructor_next (c
))
8471 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
8472 if (tmp
== &gfc_bad_expr
)
8474 gfc_free_expr (result
);
8475 return &gfc_bad_expr
;
8480 gfc_free_expr (result
);
8484 gfc_constructor_append_expr (&result
->value
.constructor
,
8496 gfc_simplify_compiler_options (void)
8501 str
= gfc_get_option_string ();
8502 result
= gfc_get_character_expr (gfc_default_character_kind
,
8503 &gfc_current_locus
, str
, strlen (str
));
8510 gfc_simplify_compiler_version (void)
8515 len
= strlen ("GCC version ") + strlen (version_string
);
8516 buffer
= XALLOCAVEC (char, len
+ 1);
8517 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
8518 return gfc_get_character_expr (gfc_default_character_kind
,
8519 &gfc_current_locus
, buffer
, len
);
8522 /* Simplification routines for intrinsics of IEEE modules. */
8525 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
8527 gfc_actual_arglist
*arg
;
8528 gfc_expr
*p
= NULL
, *q
= NULL
, *rdx
= NULL
;
8530 arg
= expr
->value
.function
.actual
;
8534 q
= arg
->next
->expr
;
8535 if (arg
->next
->next
)
8536 rdx
= arg
->next
->next
->expr
;
8539 /* Currently, if IEEE is supported and this module is built, it means
8540 all our floating-point types conform to IEEE. Hence, we simply handle
8541 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
8542 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
8546 simplify_ieee_support (gfc_expr
*expr
)
8548 /* We consider that if the IEEE modules are loaded, we have full support
8549 for flags, halting and rounding, which are the three functions
8550 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
8551 expressions. One day, we will need libgfortran to detect support and
8552 communicate it back to us, allowing for partial support. */
8554 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
8559 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
8561 int n
= strlen(name
);
8563 if (!strncmp(sym
->name
, name
, n
))
8566 /* If a generic was used and renamed, we need more work to find out.
8567 Compare the specific name. */
8568 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
8575 gfc_simplify_ieee_functions (gfc_expr
*expr
)
8577 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
8579 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
8580 return simplify_ieee_selected_real_kind (expr
);
8581 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
8582 || matches_ieee_function_name(sym
, "ieee_support_halting")
8583 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
8584 return simplify_ieee_support (expr
);