1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2016 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"
28 #include "target-memory.h"
29 #include "constructor.h"
30 #include "version.h" /* For version_string. */
33 gfc_expr gfc_bad_expr
;
35 static gfc_expr
*simplify_size (gfc_expr
*, gfc_expr
*, int);
38 /* Note that 'simplification' is not just transforming expressions.
39 For functions that are not simplified at compile time, range
40 checking is done if possible.
42 The return convention is that each simplification function returns:
44 A new expression node corresponding to the simplified arguments.
45 The original arguments are destroyed by the caller, and must not
46 be a part of the new expression.
48 NULL pointer indicating that no simplification was possible and
49 the original expression should remain intact.
51 An expression pointer to gfc_bad_expr (a static placeholder)
52 indicating that some error has prevented simplification. The
53 error is generated within the function and should be propagated
56 By the time a simplification function gets control, it has been
57 decided that the function call is really supposed to be the
58 intrinsic. No type checking is strictly necessary, since only
59 valid types will be passed on. On the other hand, a simplification
60 subroutine may have to look at the type of an argument as part of
63 Array arguments are only passed to these subroutines that implement
64 the simplification of transformational intrinsics.
66 The functions in this file don't have much comment with them, but
67 everything is reasonably straight-forward. The Standard, chapter 13
68 is the best comment you'll find for this file anyway. */
70 /* Range checks an expression node. If all goes well, returns the
71 node, otherwise returns &gfc_bad_expr and frees the node. */
74 range_check (gfc_expr
*result
, const char *name
)
79 if (result
->expr_type
!= EXPR_CONSTANT
)
82 switch (gfc_range_check (result
))
88 gfc_error ("Result of %s overflows its kind at %L", name
,
93 gfc_error ("Result of %s underflows its kind at %L", name
,
98 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
102 gfc_error ("Result of %s gives range error for its kind at %L", name
,
107 gfc_free_expr (result
);
108 return &gfc_bad_expr
;
112 /* A helper function that gets an optional and possibly missing
113 kind parameter. Returns the kind, -1 if something went wrong. */
116 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
123 if (k
->expr_type
!= EXPR_CONSTANT
)
125 gfc_error ("KIND parameter of %s at %L must be an initialization "
126 "expression", name
, &k
->where
);
130 if (gfc_extract_int (k
, &kind
) != NULL
131 || gfc_validate_kind (type
, kind
, true) < 0)
133 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
141 /* Converts an mpz_t signed variable into an unsigned one, assuming
142 two's complement representations and a binary width of bitsize.
143 The conversion is a no-op unless x is negative; otherwise, it can
144 be accomplished by masking out the high bits. */
147 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
153 /* Confirm that no bits above the signed range are unset if we
154 are doing range checking. */
155 if (flag_range_check
!= 0)
156 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
158 mpz_init_set_ui (mask
, 1);
159 mpz_mul_2exp (mask
, mask
, bitsize
);
160 mpz_sub_ui (mask
, mask
, 1);
162 mpz_and (x
, x
, mask
);
168 /* Confirm that no bits above the signed range are set. */
169 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
174 /* Converts an mpz_t unsigned variable into a signed one, assuming
175 two's complement representations and a binary width of bitsize.
176 If the bitsize-1 bit is set, this is taken as a sign bit and
177 the number is converted to the corresponding negative number. */
180 gfc_convert_mpz_to_signed (mpz_t x
, int bitsize
)
184 /* Confirm that no bits above the unsigned range are set if we are
185 doing range checking. */
186 if (flag_range_check
!= 0)
187 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
189 if (mpz_tstbit (x
, bitsize
- 1) == 1)
191 mpz_init_set_ui (mask
, 1);
192 mpz_mul_2exp (mask
, mask
, bitsize
);
193 mpz_sub_ui (mask
, mask
, 1);
195 /* We negate the number by hand, zeroing the high bits, that is
196 make it the corresponding positive number, and then have it
197 negated by GMP, giving the correct representation of the
200 mpz_add_ui (x
, x
, 1);
201 mpz_and (x
, x
, mask
);
210 /* In-place convert BOZ to REAL of the specified kind. */
213 convert_boz (gfc_expr
*x
, int kind
)
215 if (x
&& x
->ts
.type
== BT_INTEGER
&& x
->is_boz
)
222 if (!gfc_convert_boz (x
, &ts
))
223 return &gfc_bad_expr
;
230 /* Test that the expression is an constant array. */
233 is_constant_array_expr (gfc_expr
*e
)
240 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
243 for (c
= gfc_constructor_first (e
->value
.constructor
);
244 c
; c
= gfc_constructor_next (c
))
245 if (c
->expr
->expr_type
!= EXPR_CONSTANT
246 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
253 /* Initialize a transformational result expression with a given value. */
256 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
258 if (e
&& e
->expr_type
== EXPR_ARRAY
)
260 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
263 init_result_expr (ctor
->expr
, init
, array
);
264 ctor
= gfc_constructor_next (ctor
);
267 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
269 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
276 e
->value
.logical
= (init
? 1 : 0);
281 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
282 else if (init
== INT_MAX
)
283 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
285 mpz_set_si (e
->value
.integer
, init
);
291 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
292 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
294 else if (init
== INT_MAX
)
295 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
297 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
301 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
307 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
308 gfc_extract_int (len
, &length
);
309 string
= gfc_get_wide_string (length
+ 1);
310 gfc_wide_memset (string
, 0, length
);
312 else if (init
== INT_MAX
)
314 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
315 gfc_extract_int (len
, &length
);
316 string
= gfc_get_wide_string (length
+ 1);
317 gfc_wide_memset (string
, 255, length
);
322 string
= gfc_get_wide_string (1);
325 string
[length
] = '\0';
326 e
->value
.character
.length
= length
;
327 e
->value
.character
.string
= string
;
339 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
340 if conj_a is true, the matrix_a is complex conjugated. */
343 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
344 gfc_expr
*matrix_b
, int stride_b
, int offset_b
,
347 gfc_expr
*result
, *a
, *b
, *c
;
349 result
= gfc_get_constant_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
351 init_result_expr (result
, 0, NULL
);
353 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
354 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
357 /* Copying of expressions is required as operands are free'd
358 by the gfc_arith routines. */
359 switch (result
->ts
.type
)
362 result
= gfc_or (result
,
363 gfc_and (gfc_copy_expr (a
),
370 if (conj_a
&& a
->ts
.type
== BT_COMPLEX
)
371 c
= gfc_simplify_conjg (a
);
373 c
= gfc_copy_expr (a
);
374 result
= gfc_add (result
, gfc_multiply (c
, gfc_copy_expr (b
)));
381 offset_a
+= stride_a
;
382 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
384 offset_b
+= stride_b
;
385 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
392 /* Build a result expression for transformational intrinsics,
396 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
397 int kind
, locus
* where
)
402 if (!dim
|| array
->rank
== 1)
403 return gfc_get_constant_expr (type
, kind
, where
);
405 result
= gfc_get_array_expr (type
, kind
, where
);
406 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
407 result
->rank
= array
->rank
- 1;
409 /* gfc_array_size() would count the number of elements in the constructor,
410 we have not built those yet. */
412 for (i
= 0; i
< result
->rank
; ++i
)
413 nelem
*= mpz_get_ui (result
->shape
[i
]);
415 for (i
= 0; i
< nelem
; ++i
)
417 gfc_constructor_append_expr (&result
->value
.constructor
,
418 gfc_get_constant_expr (type
, kind
, where
),
426 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
428 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
429 of COUNT intrinsic is .TRUE..
431 Interface and implementation mimics arith functions as
432 gfc_add, gfc_multiply, etc. */
434 static gfc_expr
* gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
438 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
439 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
440 gcc_assert (op2
->value
.logical
);
442 result
= gfc_copy_expr (op1
);
443 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
451 /* Transforms an ARRAY with operation OP, according to MASK, to a
452 scalar RESULT. E.g. called if
454 REAL, PARAMETER :: array(n, m) = ...
455 REAL, PARAMETER :: s = SUM(array)
457 where OP == gfc_add(). */
460 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
461 transformational_op op
)
464 gfc_constructor
*array_ctor
, *mask_ctor
;
466 /* Shortcut for constant .FALSE. MASK. */
468 && mask
->expr_type
== EXPR_CONSTANT
469 && !mask
->value
.logical
)
472 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
474 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
475 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
479 a
= array_ctor
->expr
;
480 array_ctor
= gfc_constructor_next (array_ctor
);
482 /* A constant MASK equals .TRUE. here and can be ignored. */
486 mask_ctor
= gfc_constructor_next (mask_ctor
);
487 if (!m
->value
.logical
)
491 result
= op (result
, gfc_copy_expr (a
));
497 /* Transforms an ARRAY with operation OP, according to MASK, to an
498 array RESULT. E.g. called if
500 REAL, PARAMETER :: array(n, m) = ...
501 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
503 where OP == gfc_multiply().
504 The result might be post processed using post_op. */
507 simplify_transformation_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*dim
,
508 gfc_expr
*mask
, transformational_op op
,
509 transformational_op post_op
)
512 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
513 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
514 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
516 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
517 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
518 tmpstride
[GFC_MAX_DIMENSIONS
];
520 /* Shortcut for constant .FALSE. MASK. */
522 && mask
->expr_type
== EXPR_CONSTANT
523 && !mask
->value
.logical
)
526 /* Build an indexed table for array element expressions to minimize
527 linked-list traversal. Masked elements are set to NULL. */
528 gfc_array_size (array
, &size
);
529 arraysize
= mpz_get_ui (size
);
532 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
534 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
536 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
537 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
539 for (i
= 0; i
< arraysize
; ++i
)
541 arrayvec
[i
] = array_ctor
->expr
;
542 array_ctor
= gfc_constructor_next (array_ctor
);
546 if (!mask_ctor
->expr
->value
.logical
)
549 mask_ctor
= gfc_constructor_next (mask_ctor
);
553 /* Same for the result expression. */
554 gfc_array_size (result
, &size
);
555 resultsize
= mpz_get_ui (size
);
558 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
559 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
560 for (i
= 0; i
< resultsize
; ++i
)
562 resultvec
[i
] = result_ctor
->expr
;
563 result_ctor
= gfc_constructor_next (result_ctor
);
566 gfc_extract_int (dim
, &dim_index
);
567 dim_index
-= 1; /* zero-base index */
571 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
574 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
577 dim_extent
= mpz_get_si (array
->shape
[i
]);
578 dim_stride
= tmpstride
[i
];
582 extent
[n
] = mpz_get_si (array
->shape
[i
]);
583 sstride
[n
] = tmpstride
[i
];
584 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
593 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
595 *dest
= op (*dest
, gfc_copy_expr (*src
));
602 while (!done
&& count
[n
] == extent
[n
])
605 base
-= sstride
[n
] * extent
[n
];
606 dest
-= dstride
[n
] * extent
[n
];
609 if (n
< result
->rank
)
620 /* Place updated expression in result constructor. */
621 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
622 for (i
= 0; i
< resultsize
; ++i
)
625 result_ctor
->expr
= post_op (result_ctor
->expr
, resultvec
[i
]);
627 result_ctor
->expr
= resultvec
[i
];
628 result_ctor
= gfc_constructor_next (result_ctor
);
638 simplify_transformation (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
639 int init_val
, transformational_op op
)
643 if (!is_constant_array_expr (array
)
644 || !gfc_is_constant_expr (dim
))
648 && !is_constant_array_expr (mask
)
649 && mask
->expr_type
!= EXPR_CONSTANT
)
652 result
= transformational_result (array
, dim
, array
->ts
.type
,
653 array
->ts
.kind
, &array
->where
);
654 init_result_expr (result
, init_val
, NULL
);
656 return !dim
|| array
->rank
== 1 ?
657 simplify_transformation_to_scalar (result
, array
, mask
, op
) :
658 simplify_transformation_to_array (result
, array
, dim
, mask
, op
, NULL
);
662 /********************** Simplification functions *****************************/
665 gfc_simplify_abs (gfc_expr
*e
)
669 if (e
->expr_type
!= EXPR_CONSTANT
)
675 result
= gfc_get_constant_expr (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
676 mpz_abs (result
->value
.integer
, e
->value
.integer
);
677 return range_check (result
, "IABS");
680 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
681 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
682 return range_check (result
, "ABS");
685 gfc_set_model_kind (e
->ts
.kind
);
686 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
687 mpc_abs (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
688 return range_check (result
, "CABS");
691 gfc_internal_error ("gfc_simplify_abs(): Bad type");
697 simplify_achar_char (gfc_expr
*e
, gfc_expr
*k
, const char *name
, bool ascii
)
701 bool too_large
= false;
703 if (e
->expr_type
!= EXPR_CONSTANT
)
706 kind
= get_kind (BT_CHARACTER
, k
, name
, gfc_default_character_kind
);
708 return &gfc_bad_expr
;
710 if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
712 gfc_error ("Argument of %s function at %L is negative", name
,
714 return &gfc_bad_expr
;
717 if (ascii
&& warn_surprising
&& mpz_cmp_si (e
->value
.integer
, 127) > 0)
718 gfc_warning (OPT_Wsurprising
,
719 "Argument of %s function at %L outside of range [0,127]",
722 if (kind
== 1 && mpz_cmp_si (e
->value
.integer
, 255) > 0)
727 mpz_init_set_ui (t
, 2);
728 mpz_pow_ui (t
, t
, 32);
729 mpz_sub_ui (t
, t
, 1);
730 if (mpz_cmp (e
->value
.integer
, t
) > 0)
737 gfc_error ("Argument of %s function at %L is too large for the "
738 "collating sequence of kind %d", name
, &e
->where
, kind
);
739 return &gfc_bad_expr
;
742 result
= gfc_get_character_expr (kind
, &e
->where
, NULL
, 1);
743 result
->value
.character
.string
[0] = mpz_get_ui (e
->value
.integer
);
750 /* We use the processor's collating sequence, because all
751 systems that gfortran currently works on are ASCII. */
754 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
756 return simplify_achar_char (e
, k
, "ACHAR", true);
761 gfc_simplify_acos (gfc_expr
*x
)
765 if (x
->expr_type
!= EXPR_CONSTANT
)
771 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
772 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
774 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
776 return &gfc_bad_expr
;
778 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
779 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
783 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
784 mpc_acos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
788 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
791 return range_check (result
, "ACOS");
795 gfc_simplify_acosh (gfc_expr
*x
)
799 if (x
->expr_type
!= EXPR_CONSTANT
)
805 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
807 gfc_error ("Argument of ACOSH at %L must not be less than 1",
809 return &gfc_bad_expr
;
812 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
813 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
817 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
818 mpc_acosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
822 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
825 return range_check (result
, "ACOSH");
829 gfc_simplify_adjustl (gfc_expr
*e
)
835 if (e
->expr_type
!= EXPR_CONSTANT
)
838 len
= e
->value
.character
.length
;
840 for (count
= 0, i
= 0; i
< len
; ++i
)
842 ch
= e
->value
.character
.string
[i
];
848 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
849 for (i
= 0; i
< len
- count
; ++i
)
850 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
857 gfc_simplify_adjustr (gfc_expr
*e
)
863 if (e
->expr_type
!= EXPR_CONSTANT
)
866 len
= e
->value
.character
.length
;
868 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
870 ch
= e
->value
.character
.string
[i
];
876 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
877 for (i
= 0; i
< count
; ++i
)
878 result
->value
.character
.string
[i
] = ' ';
880 for (i
= count
; i
< len
; ++i
)
881 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
888 gfc_simplify_aimag (gfc_expr
*e
)
892 if (e
->expr_type
!= EXPR_CONSTANT
)
895 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
896 mpfr_set (result
->value
.real
, mpc_imagref (e
->value
.complex), GFC_RND_MODE
);
898 return range_check (result
, "AIMAG");
903 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
905 gfc_expr
*rtrunc
, *result
;
908 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
910 return &gfc_bad_expr
;
912 if (e
->expr_type
!= EXPR_CONSTANT
)
915 rtrunc
= gfc_copy_expr (e
);
916 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
918 result
= gfc_real2real (rtrunc
, kind
);
920 gfc_free_expr (rtrunc
);
922 return range_check (result
, "AINT");
927 gfc_simplify_all (gfc_expr
*mask
, gfc_expr
*dim
)
929 return simplify_transformation (mask
, dim
, NULL
, true, gfc_and
);
934 gfc_simplify_dint (gfc_expr
*e
)
936 gfc_expr
*rtrunc
, *result
;
938 if (e
->expr_type
!= EXPR_CONSTANT
)
941 rtrunc
= gfc_copy_expr (e
);
942 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
944 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
946 gfc_free_expr (rtrunc
);
948 return range_check (result
, "DINT");
953 gfc_simplify_dreal (gfc_expr
*e
)
955 gfc_expr
*result
= NULL
;
957 if (e
->expr_type
!= EXPR_CONSTANT
)
960 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
961 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
963 return range_check (result
, "DREAL");
968 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
973 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
975 return &gfc_bad_expr
;
977 if (e
->expr_type
!= EXPR_CONSTANT
)
980 result
= gfc_get_constant_expr (e
->ts
.type
, kind
, &e
->where
);
981 mpfr_round (result
->value
.real
, e
->value
.real
);
983 return range_check (result
, "ANINT");
988 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
993 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
996 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1001 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
1002 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1003 return range_check (result
, "AND");
1006 return gfc_get_logical_expr (kind
, &x
->where
,
1007 x
->value
.logical
&& y
->value
.logical
);
1016 gfc_simplify_any (gfc_expr
*mask
, gfc_expr
*dim
)
1018 return simplify_transformation (mask
, dim
, NULL
, false, gfc_or
);
1023 gfc_simplify_dnint (gfc_expr
*e
)
1027 if (e
->expr_type
!= EXPR_CONSTANT
)
1030 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &e
->where
);
1031 mpfr_round (result
->value
.real
, e
->value
.real
);
1033 return range_check (result
, "DNINT");
1038 gfc_simplify_asin (gfc_expr
*x
)
1042 if (x
->expr_type
!= EXPR_CONSTANT
)
1048 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1049 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1051 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1053 return &gfc_bad_expr
;
1055 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1056 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1060 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1061 mpc_asin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1065 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1068 return range_check (result
, "ASIN");
1073 gfc_simplify_asinh (gfc_expr
*x
)
1077 if (x
->expr_type
!= EXPR_CONSTANT
)
1080 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1085 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1089 mpc_asinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1093 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1096 return range_check (result
, "ASINH");
1101 gfc_simplify_atan (gfc_expr
*x
)
1105 if (x
->expr_type
!= EXPR_CONSTANT
)
1108 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1113 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1117 mpc_atan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1121 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1124 return range_check (result
, "ATAN");
1129 gfc_simplify_atanh (gfc_expr
*x
)
1133 if (x
->expr_type
!= EXPR_CONSTANT
)
1139 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
1140 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
1142 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1144 return &gfc_bad_expr
;
1146 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1147 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1151 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1152 mpc_atanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1156 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1159 return range_check (result
, "ATANH");
1164 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1168 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1171 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1173 gfc_error ("If first argument of ATAN2 %L is zero, then the "
1174 "second argument must not be zero", &x
->where
);
1175 return &gfc_bad_expr
;
1178 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1179 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1181 return range_check (result
, "ATAN2");
1186 gfc_simplify_bessel_j0 (gfc_expr
*x
)
1190 if (x
->expr_type
!= EXPR_CONSTANT
)
1193 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1194 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1196 return range_check (result
, "BESSEL_J0");
1201 gfc_simplify_bessel_j1 (gfc_expr
*x
)
1205 if (x
->expr_type
!= EXPR_CONSTANT
)
1208 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1209 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1211 return range_check (result
, "BESSEL_J1");
1216 gfc_simplify_bessel_jn (gfc_expr
*order
, gfc_expr
*x
)
1221 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1224 n
= mpz_get_si (order
->value
.integer
);
1225 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1226 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1228 return range_check (result
, "BESSEL_JN");
1232 /* Simplify transformational form of JN and YN. */
1235 gfc_simplify_bessel_n2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
,
1242 mpfr_t x2rev
, last1
, last2
;
1244 if (x
->expr_type
!= EXPR_CONSTANT
|| order1
->expr_type
!= EXPR_CONSTANT
1245 || order2
->expr_type
!= EXPR_CONSTANT
)
1248 n1
= mpz_get_si (order1
->value
.integer
);
1249 n2
= mpz_get_si (order2
->value
.integer
);
1250 result
= gfc_get_array_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1252 result
->shape
= gfc_get_shape (1);
1253 mpz_init_set_ui (result
->shape
[0], MAX (n2
-n1
+1, 0));
1258 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1259 YN(N, 0.0) = -Inf. */
1261 if (mpfr_cmp_ui (x
->value
.real
, 0.0) == 0)
1263 if (!jn
&& flag_range_check
)
1265 gfc_error ("Result of BESSEL_YN is -INF at %L", &result
->where
);
1266 gfc_free_expr (result
);
1267 return &gfc_bad_expr
;
1272 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1273 mpfr_set_ui (e
->value
.real
, 1, GFC_RND_MODE
);
1274 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1279 for (i
= n1
; i
<= n2
; i
++)
1281 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1283 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
1285 mpfr_set_inf (e
->value
.real
, -1);
1286 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1293 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1294 are stable for downward recursion and Neumann functions are stable
1295 for upward recursion. It is
1297 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1298 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1299 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1301 gfc_set_model_kind (x
->ts
.kind
);
1303 /* Get first recursion anchor. */
1307 mpfr_jn (last1
, n2
, x
->value
.real
, GFC_RND_MODE
);
1309 mpfr_yn (last1
, n1
, x
->value
.real
, GFC_RND_MODE
);
1311 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1312 mpfr_set (e
->value
.real
, last1
, GFC_RND_MODE
);
1313 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1317 gfc_free_expr (result
);
1318 return &gfc_bad_expr
;
1320 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1328 /* Get second recursion anchor. */
1332 mpfr_jn (last2
, n2
-1, x
->value
.real
, GFC_RND_MODE
);
1334 mpfr_yn (last2
, n1
+1, x
->value
.real
, GFC_RND_MODE
);
1336 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1337 mpfr_set (e
->value
.real
, last2
, GFC_RND_MODE
);
1338 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1343 gfc_free_expr (result
);
1344 return &gfc_bad_expr
;
1347 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
, -2);
1349 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1358 /* Start actual recursion. */
1361 mpfr_ui_div (x2rev
, 2, x
->value
.real
, GFC_RND_MODE
);
1363 for (i
= 2; i
<= n2
-n1
; i
++)
1365 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1367 /* Special case: For YN, if the previous N gave -INF, set
1368 also N+1 to -INF. */
1369 if (!jn
&& !flag_range_check
&& mpfr_inf_p (last2
))
1371 mpfr_set_inf (e
->value
.real
, -1);
1372 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1377 mpfr_mul_si (e
->value
.real
, x2rev
, jn
? (n2
-i
+1) : (n1
+i
-1),
1379 mpfr_mul (e
->value
.real
, e
->value
.real
, last2
, GFC_RND_MODE
);
1380 mpfr_sub (e
->value
.real
, e
->value
.real
, last1
, GFC_RND_MODE
);
1382 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1384 /* Range_check frees "e" in that case. */
1390 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
,
1393 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1395 mpfr_set (last1
, last2
, GFC_RND_MODE
);
1396 mpfr_set (last2
, e
->value
.real
, GFC_RND_MODE
);
1409 gfc_free_expr (result
);
1410 return &gfc_bad_expr
;
1415 gfc_simplify_bessel_jn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1417 return gfc_simplify_bessel_n2 (order1
, order2
, x
, true);
1422 gfc_simplify_bessel_y0 (gfc_expr
*x
)
1426 if (x
->expr_type
!= EXPR_CONSTANT
)
1429 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1430 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1432 return range_check (result
, "BESSEL_Y0");
1437 gfc_simplify_bessel_y1 (gfc_expr
*x
)
1441 if (x
->expr_type
!= EXPR_CONSTANT
)
1444 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1445 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1447 return range_check (result
, "BESSEL_Y1");
1452 gfc_simplify_bessel_yn (gfc_expr
*order
, gfc_expr
*x
)
1457 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1460 n
= mpz_get_si (order
->value
.integer
);
1461 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1462 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1464 return range_check (result
, "BESSEL_YN");
1469 gfc_simplify_bessel_yn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1471 return gfc_simplify_bessel_n2 (order1
, order2
, x
, false);
1476 gfc_simplify_bit_size (gfc_expr
*e
)
1478 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1479 return gfc_get_int_expr (e
->ts
.kind
, &e
->where
,
1480 gfc_integer_kinds
[i
].bit_size
);
1485 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
1489 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
1492 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
1493 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
, false);
1495 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
,
1496 mpz_tstbit (e
->value
.integer
, b
));
1501 compare_bitwise (gfc_expr
*i
, gfc_expr
*j
)
1506 gcc_assert (i
->ts
.type
== BT_INTEGER
);
1507 gcc_assert (j
->ts
.type
== BT_INTEGER
);
1509 mpz_init_set (x
, i
->value
.integer
);
1510 k
= gfc_validate_kind (i
->ts
.type
, i
->ts
.kind
, false);
1511 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
1513 mpz_init_set (y
, j
->value
.integer
);
1514 k
= gfc_validate_kind (j
->ts
.type
, j
->ts
.kind
, false);
1515 convert_mpz_to_unsigned (y
, gfc_integer_kinds
[k
].bit_size
);
1517 res
= mpz_cmp (x
, y
);
1525 gfc_simplify_bge (gfc_expr
*i
, gfc_expr
*j
)
1527 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1530 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1531 compare_bitwise (i
, j
) >= 0);
1536 gfc_simplify_bgt (gfc_expr
*i
, gfc_expr
*j
)
1538 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1541 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1542 compare_bitwise (i
, j
) > 0);
1547 gfc_simplify_ble (gfc_expr
*i
, gfc_expr
*j
)
1549 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1552 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1553 compare_bitwise (i
, j
) <= 0);
1558 gfc_simplify_blt (gfc_expr
*i
, gfc_expr
*j
)
1560 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1563 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1564 compare_bitwise (i
, j
) < 0);
1569 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
1571 gfc_expr
*ceil
, *result
;
1574 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
1576 return &gfc_bad_expr
;
1578 if (e
->expr_type
!= EXPR_CONSTANT
)
1581 ceil
= gfc_copy_expr (e
);
1582 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
1584 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
1585 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
, &e
->where
);
1587 gfc_free_expr (ceil
);
1589 return range_check (result
, "CEILING");
1594 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
1596 return simplify_achar_char (e
, k
, "CHAR", false);
1600 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1603 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
1607 if (convert_boz (x
, kind
) == &gfc_bad_expr
)
1608 return &gfc_bad_expr
;
1610 if (convert_boz (y
, kind
) == &gfc_bad_expr
)
1611 return &gfc_bad_expr
;
1613 if (x
->expr_type
!= EXPR_CONSTANT
1614 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1617 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &x
->where
);
1622 mpc_set_z (result
->value
.complex, x
->value
.integer
, GFC_MPC_RND_MODE
);
1626 mpc_set_fr (result
->value
.complex, x
->value
.real
, GFC_RND_MODE
);
1630 mpc_set (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1634 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1638 return range_check (result
, name
);
1643 mpfr_set_z (mpc_imagref (result
->value
.complex),
1644 y
->value
.integer
, GFC_RND_MODE
);
1648 mpfr_set (mpc_imagref (result
->value
.complex),
1649 y
->value
.real
, GFC_RND_MODE
);
1653 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1656 return range_check (result
, name
);
1661 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
1665 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_complex_kind
);
1667 return &gfc_bad_expr
;
1669 return simplify_cmplx ("CMPLX", x
, y
, kind
);
1674 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
1678 if (x
->ts
.type
== BT_INTEGER
&& y
->ts
.type
== BT_INTEGER
)
1679 kind
= gfc_default_complex_kind
;
1680 else if (x
->ts
.type
== BT_REAL
|| y
->ts
.type
== BT_INTEGER
)
1682 else if (x
->ts
.type
== BT_INTEGER
|| y
->ts
.type
== BT_REAL
)
1684 else if (x
->ts
.type
== BT_REAL
&& y
->ts
.type
== BT_REAL
)
1685 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
1689 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1694 gfc_simplify_conjg (gfc_expr
*e
)
1698 if (e
->expr_type
!= EXPR_CONSTANT
)
1701 result
= gfc_copy_expr (e
);
1702 mpc_conj (result
->value
.complex, result
->value
.complex, GFC_MPC_RND_MODE
);
1704 return range_check (result
, "CONJG");
1709 gfc_simplify_cos (gfc_expr
*x
)
1713 if (x
->expr_type
!= EXPR_CONSTANT
)
1716 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1721 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1725 gfc_set_model_kind (x
->ts
.kind
);
1726 mpc_cos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1730 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1733 return range_check (result
, "COS");
1738 gfc_simplify_cosh (gfc_expr
*x
)
1742 if (x
->expr_type
!= EXPR_CONSTANT
)
1745 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1750 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1754 mpc_cosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1761 return range_check (result
, "COSH");
1766 gfc_simplify_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1770 if (!is_constant_array_expr (mask
)
1771 || !gfc_is_constant_expr (dim
)
1772 || !gfc_is_constant_expr (kind
))
1775 result
= transformational_result (mask
, dim
,
1777 get_kind (BT_INTEGER
, kind
, "COUNT",
1778 gfc_default_integer_kind
),
1781 init_result_expr (result
, 0, NULL
);
1783 /* Passing MASK twice, once as data array, once as mask.
1784 Whenever gfc_count is called, '1' is added to the result. */
1785 return !dim
|| mask
->rank
== 1 ?
1786 simplify_transformation_to_scalar (result
, mask
, mask
, gfc_count
) :
1787 simplify_transformation_to_array (result
, mask
, dim
, mask
, gfc_count
, NULL
);
1792 gfc_simplify_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1794 gfc_expr
*a
, *result
;
1797 /* DIM is only useful for rank > 1, but deal with it here as one can
1798 set DIM = 1 for rank = 1. */
1801 if (!gfc_is_constant_expr (dim
))
1803 dm
= mpz_get_si (dim
->value
.integer
);
1808 /* Copy array into 'a', simplify it, and then test for a constant array. */
1809 a
= gfc_copy_expr (array
);
1810 gfc_simplify_expr (a
, 0);
1811 if (!is_constant_array_expr (a
))
1819 gfc_constructor
*ca
, *cr
;
1823 if (!gfc_is_constant_expr (shift
))
1829 shft
= mpz_get_si (shift
->value
.integer
);
1831 /* Case (i): If ARRAY has rank one, element i of the result is
1832 ARRAY (1 + MODULO (i + SHIFT - 1, SIZE (ARRAY))). */
1835 gfc_array_size (a
, &size
);
1836 sz
= mpz_get_si (size
);
1839 /* Adjust shft to deal with right or left shifts. */
1840 shft
= shft
< 0 ? 1 - shft
: shft
;
1842 /* Special case: Shift to the original order! */
1846 result
= gfc_copy_expr (a
);
1847 cr
= gfc_constructor_first (result
->value
.constructor
);
1848 for (i
= 0; i
< sz
; i
++, cr
= gfc_constructor_next (cr
))
1850 j
= (i
+ shft
) % sz
;
1851 ca
= gfc_constructor_first (a
->value
.constructor
);
1853 ca
= gfc_constructor_next (ca
);
1854 cr
->expr
= gfc_copy_expr (ca
->expr
);
1862 /* FIXME: Deal with rank > 1 arrays. For now, don't leak memory. */
1864 /* GCC bootstrap is too stupid to realize that the above code for dm
1865 is correct. First, dim can be specified for a rank 1 array. It is
1866 not needed in this nor used here. Second, the code is simply waiting
1867 for someone to implement rank > 1 simplification. For now, add a
1868 pessimization to the code that has a zero valid reason to be here. */
1869 if (dm
> array
->rank
)
1880 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
1882 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
1887 gfc_simplify_dble (gfc_expr
*e
)
1889 gfc_expr
*result
= NULL
;
1891 if (e
->expr_type
!= EXPR_CONSTANT
)
1894 if (convert_boz (e
, gfc_default_double_kind
) == &gfc_bad_expr
)
1895 return &gfc_bad_expr
;
1897 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
1898 if (result
== &gfc_bad_expr
)
1899 return &gfc_bad_expr
;
1901 return range_check (result
, "DBLE");
1906 gfc_simplify_digits (gfc_expr
*x
)
1910 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
1915 digits
= gfc_integer_kinds
[i
].digits
;
1920 digits
= gfc_real_kinds
[i
].digits
;
1927 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
1932 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
1937 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1940 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1941 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
1946 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
1947 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1949 mpz_set_ui (result
->value
.integer
, 0);
1954 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
1955 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
1958 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
1963 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1966 return range_check (result
, "DIM");
1971 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
1976 if (!is_constant_array_expr (vector_a
)
1977 || !is_constant_array_expr (vector_b
))
1980 gcc_assert (vector_a
->rank
== 1);
1981 gcc_assert (vector_b
->rank
== 1);
1983 temp
.expr_type
= EXPR_OP
;
1984 gfc_clear_ts (&temp
.ts
);
1985 temp
.value
.op
.op
= INTRINSIC_NONE
;
1986 temp
.value
.op
.op1
= vector_a
;
1987 temp
.value
.op
.op2
= vector_b
;
1988 gfc_type_convert_binary (&temp
, 1);
1990 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
1995 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
1997 gfc_expr
*a1
, *a2
, *result
;
1999 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2002 a1
= gfc_real2real (x
, gfc_default_double_kind
);
2003 a2
= gfc_real2real (y
, gfc_default_double_kind
);
2005 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
2006 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
2011 return range_check (result
, "DPROD");
2016 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
2020 int i
, k
, size
, shift
;
2022 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
2023 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
2026 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
2027 size
= gfc_integer_kinds
[k
].bit_size
;
2029 gfc_extract_int (shiftarg
, &shift
);
2031 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2033 shift
= size
- shift
;
2035 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
2036 mpz_set_ui (result
->value
.integer
, 0);
2038 for (i
= 0; i
< shift
; i
++)
2039 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
2040 mpz_setbit (result
->value
.integer
, i
);
2042 for (i
= 0; i
< size
- shift
; i
++)
2043 if (mpz_tstbit (arg1
->value
.integer
, i
))
2044 mpz_setbit (result
->value
.integer
, shift
+ i
);
2046 /* Convert to a signed value. */
2047 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
2054 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2056 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
2061 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2063 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
2068 gfc_simplify_erf (gfc_expr
*x
)
2072 if (x
->expr_type
!= EXPR_CONSTANT
)
2075 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2076 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2078 return range_check (result
, "ERF");
2083 gfc_simplify_erfc (gfc_expr
*x
)
2087 if (x
->expr_type
!= EXPR_CONSTANT
)
2090 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2091 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2093 return range_check (result
, "ERFC");
2097 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2099 #define MAX_ITER 200
2100 #define ARG_LIMIT 12
2102 /* Calculate ERFC_SCALED directly by its definition:
2104 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2106 using a large precision for intermediate results. This is used for all
2107 but large values of the argument. */
2109 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2114 prec
= mpfr_get_default_prec ();
2115 mpfr_set_default_prec (10 * prec
);
2120 mpfr_set (a
, arg
, GFC_RND_MODE
);
2121 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2122 mpfr_exp (b
, b
, GFC_RND_MODE
);
2123 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2124 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2126 mpfr_set (res
, a
, GFC_RND_MODE
);
2127 mpfr_set_default_prec (prec
);
2133 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2135 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2136 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2139 This is used for large values of the argument. Intermediate calculations
2140 are performed with twice the precision. We don't do a fixed number of
2141 iterations of the sum, but stop when it has converged to the required
2144 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2146 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2151 prec
= mpfr_get_default_prec ();
2152 mpfr_set_default_prec (2 * prec
);
2162 mpfr_init (sumtrunc
);
2163 mpfr_set_prec (oldsum
, prec
);
2164 mpfr_set_prec (sumtrunc
, prec
);
2166 mpfr_set (x
, arg
, GFC_RND_MODE
);
2167 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2168 mpz_set_ui (num
, 1);
2170 mpfr_set (u
, x
, GFC_RND_MODE
);
2171 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2172 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2173 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2175 for (i
= 1; i
< MAX_ITER
; i
++)
2177 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2179 mpz_mul_ui (num
, num
, 2 * i
- 1);
2182 mpfr_set (w
, u
, GFC_RND_MODE
);
2183 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2185 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2186 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2188 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2190 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2191 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2195 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2197 gcc_assert (i
< MAX_ITER
);
2199 /* Divide by x * sqrt(Pi). */
2200 mpfr_const_pi (u
, GFC_RND_MODE
);
2201 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2202 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2203 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2205 mpfr_set (res
, sum
, GFC_RND_MODE
);
2206 mpfr_set_default_prec (prec
);
2208 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2214 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2218 if (x
->expr_type
!= EXPR_CONSTANT
)
2221 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2222 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2223 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2225 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2227 return range_check (result
, "ERFC_SCALED");
2235 gfc_simplify_epsilon (gfc_expr
*e
)
2240 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2242 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2243 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2245 return range_check (result
, "EPSILON");
2250 gfc_simplify_exp (gfc_expr
*x
)
2254 if (x
->expr_type
!= EXPR_CONSTANT
)
2257 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2262 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2266 gfc_set_model_kind (x
->ts
.kind
);
2267 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2271 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2274 return range_check (result
, "EXP");
2279 gfc_simplify_exponent (gfc_expr
*x
)
2284 if (x
->expr_type
!= EXPR_CONSTANT
)
2287 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2290 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2291 if (mpfr_inf_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
2293 int i
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
2294 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2298 /* EXPONENT(+/- 0.0) = 0 */
2299 if (mpfr_zero_p (x
->value
.real
))
2301 mpz_set_ui (result
->value
.integer
, 0);
2305 gfc_set_model (x
->value
.real
);
2307 val
= (long int) mpfr_get_exp (x
->value
.real
);
2308 mpz_set_si (result
->value
.integer
, val
);
2310 return range_check (result
, "EXPONENT");
2315 gfc_simplify_float (gfc_expr
*a
)
2319 if (a
->expr_type
!= EXPR_CONSTANT
)
2324 if (convert_boz (a
, gfc_default_real_kind
) == &gfc_bad_expr
)
2325 return &gfc_bad_expr
;
2327 result
= gfc_copy_expr (a
);
2330 result
= gfc_int2real (a
, gfc_default_real_kind
);
2332 return range_check (result
, "FLOAT");
2337 is_last_ref_vtab (gfc_expr
*e
)
2340 gfc_component
*comp
= NULL
;
2342 if (e
->expr_type
!= EXPR_VARIABLE
)
2345 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2346 if (ref
->type
== REF_COMPONENT
)
2347 comp
= ref
->u
.c
.component
;
2349 if (!e
->ref
|| !comp
)
2350 return e
->symtree
->n
.sym
->attr
.vtab
;
2352 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
2360 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
2362 /* Avoid simplification of resolved symbols. */
2363 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
2366 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
2367 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2368 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2371 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
2374 /* Return .false. if the dynamic type can never be the same. */
2375 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
2376 && !gfc_type_is_extension_of
2377 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2378 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
2379 && !gfc_type_is_extension_of
2380 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
2381 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
2382 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
2383 && !gfc_type_is_extension_of
2385 mold
->ts
.u
.derived
->components
->ts
.u
.derived
)
2386 && !gfc_type_is_extension_of
2387 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2389 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
2390 && !gfc_type_is_extension_of
2391 (mold
->ts
.u
.derived
,
2392 a
->ts
.u
.derived
->components
->ts
.u
.derived
)))
2393 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2395 if (mold
->ts
.type
== BT_DERIVED
2396 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2397 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
2398 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
2405 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
2407 /* Avoid simplification of resolved symbols. */
2408 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
2411 /* Return .false. if the dynamic type can never be the
2413 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
2414 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
2415 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
2416 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
2417 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2419 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
2422 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2423 gfc_compare_derived_types (a
->ts
.u
.derived
,
2429 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
2435 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
2437 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2439 if (e
->expr_type
!= EXPR_CONSTANT
)
2442 mpfr_init2 (floor
, mpfr_get_prec (e
->value
.real
));
2443 mpfr_floor (floor
, e
->value
.real
);
2445 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
2446 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
2450 return range_check (result
, "FLOOR");
2455 gfc_simplify_fraction (gfc_expr
*x
)
2459 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2460 mpfr_t absv
, exp
, pow2
;
2465 if (x
->expr_type
!= EXPR_CONSTANT
)
2468 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
2470 /* FRACTION(inf) = NaN. */
2471 if (mpfr_inf_p (x
->value
.real
))
2473 mpfr_set_nan (result
->value
.real
);
2477 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2479 /* MPFR versions before 3.1.0 do not include mpfr_frexp.
2480 TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
2482 if (mpfr_sgn (x
->value
.real
) == 0)
2484 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2488 gfc_set_model_kind (x
->ts
.kind
);
2493 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
2494 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
2496 mpfr_trunc (exp
, exp
);
2497 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
2499 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
2501 mpfr_div (result
->value
.real
, x
->value
.real
, pow2
, GFC_RND_MODE
);
2503 mpfr_clears (exp
, absv
, pow2
, NULL
);
2507 /* mpfr_frexp() correctly handles zeros and NaNs. */
2508 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2512 return range_check (result
, "FRACTION");
2517 gfc_simplify_gamma (gfc_expr
*x
)
2521 if (x
->expr_type
!= EXPR_CONSTANT
)
2524 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2525 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2527 return range_check (result
, "GAMMA");
2532 gfc_simplify_huge (gfc_expr
*e
)
2537 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2538 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2543 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2547 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
2559 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
2563 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2566 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2567 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
2568 return range_check (result
, "HYPOT");
2572 /* We use the processor's collating sequence, because all
2573 systems that gfortran currently works on are ASCII. */
2576 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
2582 if (e
->expr_type
!= EXPR_CONSTANT
)
2585 if (e
->value
.character
.length
!= 1)
2587 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
2588 return &gfc_bad_expr
;
2591 index
= e
->value
.character
.string
[0];
2593 if (warn_surprising
&& index
> 127)
2594 gfc_warning (OPT_Wsurprising
,
2595 "Argument of IACHAR function at %L outside of range 0..127",
2598 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
2600 return &gfc_bad_expr
;
2602 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2604 return range_check (result
, "IACHAR");
2609 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
2611 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2612 gcc_assert (result
->ts
.type
== BT_INTEGER
2613 && result
->expr_type
== EXPR_CONSTANT
);
2615 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2621 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2623 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
2628 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
2630 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2631 gcc_assert (result
->ts
.type
== BT_INTEGER
2632 && result
->expr_type
== EXPR_CONSTANT
);
2634 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2640 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2642 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
2647 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
2651 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2654 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2655 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2657 return range_check (result
, "IAND");
2662 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
2667 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2670 gfc_extract_int (y
, &pos
);
2672 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2674 result
= gfc_copy_expr (x
);
2676 convert_mpz_to_unsigned (result
->value
.integer
,
2677 gfc_integer_kinds
[k
].bit_size
);
2679 mpz_clrbit (result
->value
.integer
, pos
);
2681 gfc_convert_mpz_to_signed (result
->value
.integer
,
2682 gfc_integer_kinds
[k
].bit_size
);
2689 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
2696 if (x
->expr_type
!= EXPR_CONSTANT
2697 || y
->expr_type
!= EXPR_CONSTANT
2698 || z
->expr_type
!= EXPR_CONSTANT
)
2701 gfc_extract_int (y
, &pos
);
2702 gfc_extract_int (z
, &len
);
2704 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
2706 bitsize
= gfc_integer_kinds
[k
].bit_size
;
2708 if (pos
+ len
> bitsize
)
2710 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2711 "bit size at %L", &y
->where
);
2712 return &gfc_bad_expr
;
2715 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2716 convert_mpz_to_unsigned (result
->value
.integer
,
2717 gfc_integer_kinds
[k
].bit_size
);
2719 bits
= XCNEWVEC (int, bitsize
);
2721 for (i
= 0; i
< bitsize
; i
++)
2724 for (i
= 0; i
< len
; i
++)
2725 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
2727 for (i
= 0; i
< bitsize
; i
++)
2730 mpz_clrbit (result
->value
.integer
, i
);
2731 else if (bits
[i
] == 1)
2732 mpz_setbit (result
->value
.integer
, i
);
2734 gfc_internal_error ("IBITS: Bad bit");
2739 gfc_convert_mpz_to_signed (result
->value
.integer
,
2740 gfc_integer_kinds
[k
].bit_size
);
2747 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
2752 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2755 gfc_extract_int (y
, &pos
);
2757 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2759 result
= gfc_copy_expr (x
);
2761 convert_mpz_to_unsigned (result
->value
.integer
,
2762 gfc_integer_kinds
[k
].bit_size
);
2764 mpz_setbit (result
->value
.integer
, pos
);
2766 gfc_convert_mpz_to_signed (result
->value
.integer
,
2767 gfc_integer_kinds
[k
].bit_size
);
2774 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
2780 if (e
->expr_type
!= EXPR_CONSTANT
)
2783 if (e
->value
.character
.length
!= 1)
2785 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
2786 return &gfc_bad_expr
;
2789 index
= e
->value
.character
.string
[0];
2791 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
2793 return &gfc_bad_expr
;
2795 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2797 return range_check (result
, "ICHAR");
2802 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
2806 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2809 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2810 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2812 return range_check (result
, "IEOR");
2817 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
2820 int back
, len
, lensub
;
2821 int i
, j
, k
, count
, index
= 0, start
;
2823 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
2824 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
2827 if (b
!= NULL
&& b
->value
.logical
!= 0)
2832 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
2834 return &gfc_bad_expr
;
2836 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
2838 len
= x
->value
.character
.length
;
2839 lensub
= y
->value
.character
.length
;
2843 mpz_set_si (result
->value
.integer
, 0);
2851 mpz_set_si (result
->value
.integer
, 1);
2854 else if (lensub
== 1)
2856 for (i
= 0; i
< len
; i
++)
2858 for (j
= 0; j
< lensub
; j
++)
2860 if (y
->value
.character
.string
[j
]
2861 == x
->value
.character
.string
[i
])
2871 for (i
= 0; i
< len
; i
++)
2873 for (j
= 0; j
< lensub
; j
++)
2875 if (y
->value
.character
.string
[j
]
2876 == x
->value
.character
.string
[i
])
2881 for (k
= 0; k
< lensub
; k
++)
2883 if (y
->value
.character
.string
[k
]
2884 == x
->value
.character
.string
[k
+ start
])
2888 if (count
== lensub
)
2903 mpz_set_si (result
->value
.integer
, len
+ 1);
2906 else if (lensub
== 1)
2908 for (i
= 0; i
< len
; i
++)
2910 for (j
= 0; j
< lensub
; j
++)
2912 if (y
->value
.character
.string
[j
]
2913 == x
->value
.character
.string
[len
- i
])
2915 index
= len
- i
+ 1;
2923 for (i
= 0; i
< len
; i
++)
2925 for (j
= 0; j
< lensub
; j
++)
2927 if (y
->value
.character
.string
[j
]
2928 == x
->value
.character
.string
[len
- i
])
2931 if (start
<= len
- lensub
)
2934 for (k
= 0; k
< lensub
; k
++)
2935 if (y
->value
.character
.string
[k
]
2936 == x
->value
.character
.string
[k
+ start
])
2939 if (count
== lensub
)
2956 mpz_set_si (result
->value
.integer
, index
);
2957 return range_check (result
, "INDEX");
2962 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
2964 gfc_expr
*result
= NULL
;
2966 if (e
->expr_type
!= EXPR_CONSTANT
)
2969 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
2970 if (result
== &gfc_bad_expr
)
2971 return &gfc_bad_expr
;
2973 return range_check (result
, name
);
2978 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
2982 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
2984 return &gfc_bad_expr
;
2986 return simplify_intconv (e
, kind
, "INT");
2990 gfc_simplify_int2 (gfc_expr
*e
)
2992 return simplify_intconv (e
, 2, "INT2");
2997 gfc_simplify_int8 (gfc_expr
*e
)
2999 return simplify_intconv (e
, 8, "INT8");
3004 gfc_simplify_long (gfc_expr
*e
)
3006 return simplify_intconv (e
, 4, "LONG");
3011 gfc_simplify_ifix (gfc_expr
*e
)
3013 gfc_expr
*rtrunc
, *result
;
3015 if (e
->expr_type
!= EXPR_CONSTANT
)
3018 rtrunc
= gfc_copy_expr (e
);
3019 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3021 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3023 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3025 gfc_free_expr (rtrunc
);
3027 return range_check (result
, "IFIX");
3032 gfc_simplify_idint (gfc_expr
*e
)
3034 gfc_expr
*rtrunc
, *result
;
3036 if (e
->expr_type
!= EXPR_CONSTANT
)
3039 rtrunc
= gfc_copy_expr (e
);
3040 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3042 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3044 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3046 gfc_free_expr (rtrunc
);
3048 return range_check (result
, "IDINT");
3053 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
3057 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3060 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3061 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3063 return range_check (result
, "IOR");
3068 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
3070 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3071 gcc_assert (result
->ts
.type
== BT_INTEGER
3072 && result
->expr_type
== EXPR_CONSTANT
);
3074 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3080 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3082 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3087 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3089 if (x
->expr_type
!= EXPR_CONSTANT
)
3092 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3093 mpz_cmp_si (x
->value
.integer
,
3094 LIBERROR_END
) == 0);
3099 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3101 if (x
->expr_type
!= EXPR_CONSTANT
)
3104 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3105 mpz_cmp_si (x
->value
.integer
,
3106 LIBERROR_EOR
) == 0);
3111 gfc_simplify_isnan (gfc_expr
*x
)
3113 if (x
->expr_type
!= EXPR_CONSTANT
)
3116 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3117 mpfr_nan_p (x
->value
.real
));
3121 /* Performs a shift on its first argument. Depending on the last
3122 argument, the shift can be arithmetic, i.e. with filling from the
3123 left like in the SHIFTA intrinsic. */
3125 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3126 bool arithmetic
, int direction
)
3129 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3131 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3134 gfc_extract_int (s
, &shift
);
3136 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3137 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3139 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3143 mpz_set (result
->value
.integer
, e
->value
.integer
);
3147 if (direction
> 0 && shift
< 0)
3149 /* Left shift, as in SHIFTL. */
3150 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3151 return &gfc_bad_expr
;
3153 else if (direction
< 0)
3155 /* Right shift, as in SHIFTR or SHIFTA. */
3158 gfc_error ("Second argument of %s is negative at %L",
3160 return &gfc_bad_expr
;
3166 ashift
= (shift
>= 0 ? shift
: -shift
);
3168 if (ashift
> bitsize
)
3170 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3171 "at %L", name
, &e
->where
);
3172 return &gfc_bad_expr
;
3175 bits
= XCNEWVEC (int, bitsize
);
3177 for (i
= 0; i
< bitsize
; i
++)
3178 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3183 for (i
= 0; i
< shift
; i
++)
3184 mpz_clrbit (result
->value
.integer
, i
);
3186 for (i
= 0; i
< bitsize
- shift
; i
++)
3189 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3191 mpz_setbit (result
->value
.integer
, i
+ shift
);
3197 if (arithmetic
&& bits
[bitsize
- 1])
3198 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3199 mpz_setbit (result
->value
.integer
, i
);
3201 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3202 mpz_clrbit (result
->value
.integer
, i
);
3204 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3207 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3209 mpz_setbit (result
->value
.integer
, i
- ashift
);
3213 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3221 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3223 return simplify_shift (e
, s
, "ISHFT", false, 0);
3228 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3230 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3235 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3237 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3242 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3244 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3249 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3251 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3256 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3258 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3263 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3266 int shift
, ashift
, isize
, ssize
, delta
, k
;
3269 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3272 gfc_extract_int (s
, &shift
);
3274 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3275 isize
= gfc_integer_kinds
[k
].bit_size
;
3279 if (sz
->expr_type
!= EXPR_CONSTANT
)
3282 gfc_extract_int (sz
, &ssize
);
3296 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3297 "BIT_SIZE of first argument at %L", &s
->where
);
3298 return &gfc_bad_expr
;
3301 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3303 mpz_set (result
->value
.integer
, e
->value
.integer
);
3308 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
3310 bits
= XCNEWVEC (int, ssize
);
3312 for (i
= 0; i
< ssize
; i
++)
3313 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3315 delta
= ssize
- ashift
;
3319 for (i
= 0; i
< delta
; i
++)
3322 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3324 mpz_setbit (result
->value
.integer
, i
+ shift
);
3327 for (i
= delta
; i
< ssize
; i
++)
3330 mpz_clrbit (result
->value
.integer
, i
- delta
);
3332 mpz_setbit (result
->value
.integer
, i
- delta
);
3337 for (i
= 0; i
< ashift
; i
++)
3340 mpz_clrbit (result
->value
.integer
, i
+ delta
);
3342 mpz_setbit (result
->value
.integer
, i
+ delta
);
3345 for (i
= ashift
; i
< ssize
; i
++)
3348 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3350 mpz_setbit (result
->value
.integer
, i
+ shift
);
3354 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
3362 gfc_simplify_kind (gfc_expr
*e
)
3364 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
3369 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
3370 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
3372 gfc_expr
*l
, *u
, *result
;
3375 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3376 gfc_default_integer_kind
);
3378 return &gfc_bad_expr
;
3380 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3382 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3383 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3384 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
3388 gfc_expr
* dim
= result
;
3389 mpz_set_si (dim
->value
.integer
, d
);
3391 result
= simplify_size (array
, dim
, k
);
3392 gfc_free_expr (dim
);
3397 mpz_set_si (result
->value
.integer
, 1);
3402 /* Otherwise, we have a variable expression. */
3403 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
3406 if (!gfc_resolve_array_spec (as
, 0))
3409 /* The last dimension of an assumed-size array is special. */
3410 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
3411 || (coarray
&& d
== as
->rank
+ as
->corank
3412 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
3414 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
3416 gfc_free_expr (result
);
3417 return gfc_copy_expr (as
->lower
[d
-1]);
3423 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3425 /* Then, we need to know the extent of the given dimension. */
3426 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
3428 gfc_expr
*declared_bound
;
3430 bool constant_lbound
, constant_ubound
;
3435 gcc_assert (l
!= NULL
);
3437 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
3438 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
3440 empty_bound
= upper
? 0 : 1;
3441 declared_bound
= upper
? u
: l
;
3443 if ((!upper
&& !constant_lbound
)
3444 || (upper
&& !constant_ubound
))
3449 /* For {L,U}BOUND, the value depends on whether the array
3450 is empty. We can nevertheless simplify if the declared bound
3451 has the same value as that of an empty array, in which case
3452 the result isn't dependent on the array emptyness. */
3453 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
3454 mpz_set_si (result
->value
.integer
, empty_bound
);
3455 else if (!constant_lbound
|| !constant_ubound
)
3456 /* Array emptyness can't be determined, we can't simplify. */
3458 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
3459 mpz_set_si (result
->value
.integer
, empty_bound
);
3461 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
3464 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
3470 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d
- 1, &result
->value
.integer
, NULL
))
3474 mpz_set_si (result
->value
.integer
, (long int) 1);
3478 return range_check (result
, upper
? "UBOUND" : "LBOUND");
3481 gfc_free_expr (result
);
3487 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3493 if (array
->ts
.type
== BT_CLASS
)
3496 if (array
->expr_type
!= EXPR_VARIABLE
)
3503 /* Follow any component references. */
3504 as
= array
->symtree
->n
.sym
->as
;
3505 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3510 switch (ref
->u
.ar
.type
)
3517 /* We're done because 'as' has already been set in the
3518 previous iteration. */
3532 as
= ref
->u
.c
.component
->as
;
3544 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
3545 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
3549 || (as
->type
!= AS_DEFERRED
3550 && array
->expr_type
== EXPR_VARIABLE
3551 && !gfc_expr_attr (array
).allocatable
3552 && !gfc_expr_attr (array
).pointer
));
3556 /* Multi-dimensional bounds. */
3557 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3561 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
3562 if (upper
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
3564 /* An error message will be emitted in
3565 check_assumed_size_reference (resolve.c). */
3566 return &gfc_bad_expr
;
3569 /* Simplify the bounds for each dimension. */
3570 for (d
= 0; d
< array
->rank
; d
++)
3572 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
3574 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3578 for (j
= 0; j
< d
; j
++)
3579 gfc_free_expr (bounds
[j
]);
3584 /* Allocate the result expression. */
3585 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3586 gfc_default_integer_kind
);
3588 return &gfc_bad_expr
;
3590 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
3592 /* The result is a rank 1 array; its size is the rank of the first
3593 argument to {L,U}BOUND. */
3595 e
->shape
= gfc_get_shape (1);
3596 mpz_init_set_ui (e
->shape
[0], array
->rank
);
3598 /* Create the constructor for this array. */
3599 for (d
= 0; d
< array
->rank
; d
++)
3600 gfc_constructor_append_expr (&e
->value
.constructor
,
3601 bounds
[d
], &e
->where
);
3607 /* A DIM argument is specified. */
3608 if (dim
->expr_type
!= EXPR_CONSTANT
)
3611 d
= mpz_get_si (dim
->value
.integer
);
3613 if ((d
< 1 || d
> array
->rank
)
3614 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
3616 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3617 return &gfc_bad_expr
;
3620 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3623 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
3629 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3635 if (array
->expr_type
!= EXPR_VARIABLE
)
3638 /* Follow any component references. */
3639 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
3640 ? array
->ts
.u
.derived
->components
->as
3641 : array
->symtree
->n
.sym
->as
;
3642 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3647 switch (ref
->u
.ar
.type
)
3650 if (ref
->u
.ar
.as
->corank
> 0)
3652 gcc_assert (as
== ref
->u
.ar
.as
);
3659 /* We're done because 'as' has already been set in the
3660 previous iteration. */
3674 as
= ref
->u
.c
.component
->as
;
3687 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
3692 /* Multi-dimensional cobounds. */
3693 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3697 /* Simplify the cobounds for each dimension. */
3698 for (d
= 0; d
< as
->corank
; d
++)
3700 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
3701 upper
, as
, ref
, true);
3702 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3706 for (j
= 0; j
< d
; j
++)
3707 gfc_free_expr (bounds
[j
]);
3712 /* Allocate the result expression. */
3713 e
= gfc_get_expr ();
3714 e
->where
= array
->where
;
3715 e
->expr_type
= EXPR_ARRAY
;
3716 e
->ts
.type
= BT_INTEGER
;
3717 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
3718 gfc_default_integer_kind
);
3722 return &gfc_bad_expr
;
3726 /* The result is a rank 1 array; its size is the rank of the first
3727 argument to {L,U}COBOUND. */
3729 e
->shape
= gfc_get_shape (1);
3730 mpz_init_set_ui (e
->shape
[0], as
->corank
);
3732 /* Create the constructor for this array. */
3733 for (d
= 0; d
< as
->corank
; d
++)
3734 gfc_constructor_append_expr (&e
->value
.constructor
,
3735 bounds
[d
], &e
->where
);
3740 /* A DIM argument is specified. */
3741 if (dim
->expr_type
!= EXPR_CONSTANT
)
3744 d
= mpz_get_si (dim
->value
.integer
);
3746 if (d
< 1 || d
> as
->corank
)
3748 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3749 return &gfc_bad_expr
;
3752 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
3758 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3760 return simplify_bound (array
, dim
, kind
, 0);
3765 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3767 return simplify_cobound (array
, dim
, kind
, 0);
3771 gfc_simplify_leadz (gfc_expr
*e
)
3773 unsigned long lz
, bs
;
3776 if (e
->expr_type
!= EXPR_CONSTANT
)
3779 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3780 bs
= gfc_integer_kinds
[i
].bit_size
;
3781 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
3783 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
3786 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
3788 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
3793 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
3796 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
3799 return &gfc_bad_expr
;
3801 if (e
->expr_type
== EXPR_CONSTANT
)
3803 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3804 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
3805 return range_check (result
, "LEN");
3807 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
3808 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3809 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
3811 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3812 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
3813 return range_check (result
, "LEN");
3815 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
3816 && e
->symtree
->n
.sym
3817 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
3818 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
)
3819 /* The expression in assoc->target points to a ref to the _data component
3820 of the unlimited polymorphic entity. To get the _len component the last
3821 _data ref needs to be stripped and a ref to the _len component added. */
3822 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
);
3829 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
3833 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
3836 return &gfc_bad_expr
;
3838 if (e
->expr_type
!= EXPR_CONSTANT
)
3841 len
= e
->value
.character
.length
;
3842 for (count
= 0, i
= 1; i
<= len
; i
++)
3843 if (e
->value
.character
.string
[len
- i
] == ' ')
3848 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
3849 return range_check (result
, "LEN_TRIM");
3853 gfc_simplify_lgamma (gfc_expr
*x
)
3858 if (x
->expr_type
!= EXPR_CONSTANT
)
3861 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3862 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
3864 return range_check (result
, "LGAMMA");
3869 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
3871 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3874 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3875 gfc_compare_string (a
, b
) >= 0);
3880 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
3882 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3885 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3886 gfc_compare_string (a
, b
) > 0);
3891 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
3893 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3896 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3897 gfc_compare_string (a
, b
) <= 0);
3902 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
3904 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
3907 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
3908 gfc_compare_string (a
, b
) < 0);
3913 gfc_simplify_log (gfc_expr
*x
)
3917 if (x
->expr_type
!= EXPR_CONSTANT
)
3920 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3925 if (mpfr_sgn (x
->value
.real
) <= 0)
3927 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3928 "to zero", &x
->where
);
3929 gfc_free_expr (result
);
3930 return &gfc_bad_expr
;
3933 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3937 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
3938 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
3940 gfc_error ("Complex argument of LOG at %L cannot be zero",
3942 gfc_free_expr (result
);
3943 return &gfc_bad_expr
;
3946 gfc_set_model_kind (x
->ts
.kind
);
3947 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
3951 gfc_internal_error ("gfc_simplify_log: bad type");
3954 return range_check (result
, "LOG");
3959 gfc_simplify_log10 (gfc_expr
*x
)
3963 if (x
->expr_type
!= EXPR_CONSTANT
)
3966 if (mpfr_sgn (x
->value
.real
) <= 0)
3968 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3969 "to zero", &x
->where
);
3970 return &gfc_bad_expr
;
3973 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
3974 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
3976 return range_check (result
, "LOG10");
3981 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
3985 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
3987 return &gfc_bad_expr
;
3989 if (e
->expr_type
!= EXPR_CONSTANT
)
3992 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
3997 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
4000 int row
, result_rows
, col
, result_columns
;
4001 int stride_a
, offset_a
, stride_b
, offset_b
;
4003 if (!is_constant_array_expr (matrix_a
)
4004 || !is_constant_array_expr (matrix_b
))
4007 gcc_assert (gfc_compare_types (&matrix_a
->ts
, &matrix_b
->ts
));
4008 result
= gfc_get_array_expr (matrix_a
->ts
.type
,
4012 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
4015 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4017 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4020 result
->shape
= gfc_get_shape (result
->rank
);
4021 mpz_init_set_si (result
->shape
[0], result_columns
);
4023 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
4025 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4027 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4031 result
->shape
= gfc_get_shape (result
->rank
);
4032 mpz_init_set_si (result
->shape
[0], result_rows
);
4034 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
4036 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4037 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4038 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4039 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4042 result
->shape
= gfc_get_shape (result
->rank
);
4043 mpz_init_set_si (result
->shape
[0], result_rows
);
4044 mpz_init_set_si (result
->shape
[1], result_columns
);
4049 offset_a
= offset_b
= 0;
4050 for (col
= 0; col
< result_columns
; ++col
)
4054 for (row
= 0; row
< result_rows
; ++row
)
4056 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
4057 matrix_b
, 1, offset_b
, false);
4058 gfc_constructor_append_expr (&result
->value
.constructor
,
4064 offset_b
+= stride_b
;
4072 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
4078 if (i
->expr_type
!= EXPR_CONSTANT
)
4081 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
4083 return &gfc_bad_expr
;
4084 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4086 s
= gfc_extract_int (i
, &arg
);
4089 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4091 /* MASKR(n) = 2^n - 1 */
4092 mpz_set_ui (result
->value
.integer
, 1);
4093 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4094 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4096 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4103 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4110 if (i
->expr_type
!= EXPR_CONSTANT
)
4113 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4115 return &gfc_bad_expr
;
4116 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4118 s
= gfc_extract_int (i
, &arg
);
4121 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4123 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4124 mpz_init_set_ui (z
, 1);
4125 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4126 mpz_set_ui (result
->value
.integer
, 1);
4127 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4128 gfc_integer_kinds
[k
].bit_size
- arg
);
4129 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4132 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4139 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4142 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4144 if (mask
->expr_type
== EXPR_CONSTANT
)
4145 return gfc_get_parentheses (gfc_copy_expr (mask
->value
.logical
4146 ? tsource
: fsource
));
4148 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4149 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4152 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4154 if (tsource
->ts
.type
== BT_DERIVED
)
4155 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4156 else if (tsource
->ts
.type
== BT_CHARACTER
)
4157 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4159 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4160 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4161 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4165 if (mask_ctor
->expr
->value
.logical
)
4166 gfc_constructor_append_expr (&result
->value
.constructor
,
4167 gfc_copy_expr (tsource_ctor
->expr
),
4170 gfc_constructor_append_expr (&result
->value
.constructor
,
4171 gfc_copy_expr (fsource_ctor
->expr
),
4173 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4174 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4175 mask_ctor
= gfc_constructor_next (mask_ctor
);
4178 result
->shape
= gfc_get_shape (1);
4179 gfc_array_size (result
, &result
->shape
[0]);
4186 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4188 mpz_t arg1
, arg2
, mask
;
4191 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4192 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4195 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4197 /* Convert all argument to unsigned. */
4198 mpz_init_set (arg1
, i
->value
.integer
);
4199 mpz_init_set (arg2
, j
->value
.integer
);
4200 mpz_init_set (mask
, mask_expr
->value
.integer
);
4202 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4203 mpz_and (arg1
, arg1
, mask
);
4204 mpz_com (mask
, mask
);
4205 mpz_and (arg2
, arg2
, mask
);
4206 mpz_ior (result
->value
.integer
, arg1
, arg2
);
4216 /* Selects between current value and extremum for simplify_min_max
4217 and simplify_minval_maxval. */
4219 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
)
4221 switch (arg
->ts
.type
)
4224 if (mpz_cmp (arg
->value
.integer
,
4225 extremum
->value
.integer
) * sign
> 0)
4226 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
4230 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4232 mpfr_max (extremum
->value
.real
, extremum
->value
.real
,
4233 arg
->value
.real
, GFC_RND_MODE
);
4235 mpfr_min (extremum
->value
.real
, extremum
->value
.real
,
4236 arg
->value
.real
, GFC_RND_MODE
);
4240 #define LENGTH(x) ((x)->value.character.length)
4241 #define STRING(x) ((x)->value.character.string)
4242 if (LENGTH (extremum
) < LENGTH(arg
))
4244 gfc_char_t
*tmp
= STRING(extremum
);
4246 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
4247 memcpy (STRING(extremum
), tmp
,
4248 LENGTH(extremum
) * sizeof (gfc_char_t
));
4249 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
4250 LENGTH(arg
) - LENGTH(extremum
));
4251 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
4252 LENGTH(extremum
) = LENGTH(arg
);
4256 if (gfc_compare_string (arg
, extremum
) * sign
> 0)
4258 free (STRING(extremum
));
4259 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
4260 memcpy (STRING(extremum
), STRING(arg
),
4261 LENGTH(arg
) * sizeof (gfc_char_t
));
4262 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
4263 LENGTH(extremum
) - LENGTH(arg
));
4264 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
4271 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4276 /* This function is special since MAX() can take any number of
4277 arguments. The simplified expression is a rewritten version of the
4278 argument list containing at most one constant element. Other
4279 constant elements are deleted. Because the argument list has
4280 already been checked, this function always succeeds. sign is 1 for
4281 MAX(), -1 for MIN(). */
4284 simplify_min_max (gfc_expr
*expr
, int sign
)
4286 gfc_actual_arglist
*arg
, *last
, *extremum
;
4287 gfc_intrinsic_sym
* specific
;
4291 specific
= expr
->value
.function
.isym
;
4293 arg
= expr
->value
.function
.actual
;
4295 for (; arg
; last
= arg
, arg
= arg
->next
)
4297 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
4300 if (extremum
== NULL
)
4306 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
4308 /* Delete the extra constant argument. */
4309 last
->next
= arg
->next
;
4312 gfc_free_actual_arglist (arg
);
4316 /* If there is one value left, replace the function call with the
4318 if (expr
->value
.function
.actual
->next
!= NULL
)
4321 /* Convert to the correct type and kind. */
4322 if (expr
->ts
.type
!= BT_UNKNOWN
)
4323 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4324 expr
->ts
.type
, expr
->ts
.kind
);
4326 if (specific
->ts
.type
!= BT_UNKNOWN
)
4327 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4328 specific
->ts
.type
, specific
->ts
.kind
);
4330 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
4335 gfc_simplify_min (gfc_expr
*e
)
4337 return simplify_min_max (e
, -1);
4342 gfc_simplify_max (gfc_expr
*e
)
4344 return simplify_min_max (e
, 1);
4348 /* This is a simplified version of simplify_min_max to provide
4349 simplification of minval and maxval for a vector. */
4352 simplify_minval_maxval (gfc_expr
*expr
, int sign
)
4354 gfc_constructor
*c
, *extremum
;
4355 gfc_intrinsic_sym
* specific
;
4358 specific
= expr
->value
.function
.isym
;
4360 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4361 c
; c
= gfc_constructor_next (c
))
4363 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4366 if (extremum
== NULL
)
4372 min_max_choose (c
->expr
, extremum
->expr
, sign
);
4375 if (extremum
== NULL
)
4378 /* Convert to the correct type and kind. */
4379 if (expr
->ts
.type
!= BT_UNKNOWN
)
4380 return gfc_convert_constant (extremum
->expr
,
4381 expr
->ts
.type
, expr
->ts
.kind
);
4383 if (specific
->ts
.type
!= BT_UNKNOWN
)
4384 return gfc_convert_constant (extremum
->expr
,
4385 specific
->ts
.type
, specific
->ts
.kind
);
4387 return gfc_copy_expr (extremum
->expr
);
4392 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4394 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4397 return simplify_minval_maxval (array
, -1);
4402 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4404 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4407 return simplify_minval_maxval (array
, 1);
4412 gfc_simplify_maxexponent (gfc_expr
*x
)
4414 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4415 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4416 gfc_real_kinds
[i
].max_exponent
);
4421 gfc_simplify_minexponent (gfc_expr
*x
)
4423 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4424 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4425 gfc_real_kinds
[i
].min_exponent
);
4430 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
4435 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4438 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4439 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4444 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4446 /* Result is processor-dependent. */
4447 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
4448 gfc_free_expr (result
);
4449 return &gfc_bad_expr
;
4451 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4455 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4457 /* Result is processor-dependent. */
4458 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
4459 gfc_free_expr (result
);
4460 return &gfc_bad_expr
;
4463 gfc_set_model_kind (kind
);
4464 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4469 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4472 return range_check (result
, "MOD");
4477 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
4482 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4485 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4486 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4491 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4493 /* Result is processor-dependent. This processor just opts
4494 to not handle it at all. */
4495 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
4496 gfc_free_expr (result
);
4497 return &gfc_bad_expr
;
4499 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4504 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4506 /* Result is processor-dependent. */
4507 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
4508 gfc_free_expr (result
);
4509 return &gfc_bad_expr
;
4512 gfc_set_model_kind (kind
);
4513 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4515 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
4517 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
4518 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
4522 mpfr_copysign (result
->value
.real
, result
->value
.real
,
4523 p
->value
.real
, GFC_RND_MODE
);
4527 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4530 return range_check (result
, "MODULO");
4535 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
4538 mp_exp_t emin
, emax
;
4541 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
4544 result
= gfc_copy_expr (x
);
4546 /* Save current values of emin and emax. */
4547 emin
= mpfr_get_emin ();
4548 emax
= mpfr_get_emax ();
4550 /* Set emin and emax for the current model number. */
4551 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
4552 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
4553 mpfr_get_prec(result
->value
.real
) + 1);
4554 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
4555 mpfr_check_range (result
->value
.real
, 0, GMP_RNDU
);
4557 if (mpfr_sgn (s
->value
.real
) > 0)
4559 mpfr_nextabove (result
->value
.real
);
4560 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
4564 mpfr_nextbelow (result
->value
.real
);
4565 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
4568 mpfr_set_emin (emin
);
4569 mpfr_set_emax (emax
);
4571 /* Only NaN can occur. Do not use range check as it gives an
4572 error for denormal numbers. */
4573 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
4575 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
4576 gfc_free_expr (result
);
4577 return &gfc_bad_expr
;
4585 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
4587 gfc_expr
*itrunc
, *result
;
4590 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
4592 return &gfc_bad_expr
;
4594 if (e
->expr_type
!= EXPR_CONSTANT
)
4597 itrunc
= gfc_copy_expr (e
);
4598 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
4600 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
4601 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
4603 gfc_free_expr (itrunc
);
4605 return range_check (result
, name
);
4610 gfc_simplify_new_line (gfc_expr
*e
)
4614 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
4615 result
->value
.character
.string
[0] = '\n';
4622 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
4624 return simplify_nint ("NINT", e
, k
);
4629 gfc_simplify_idnint (gfc_expr
*e
)
4631 return simplify_nint ("IDNINT", e
, NULL
);
4636 add_squared (gfc_expr
*result
, gfc_expr
*e
)
4640 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4641 gcc_assert (result
->ts
.type
== BT_REAL
4642 && result
->expr_type
== EXPR_CONSTANT
);
4644 gfc_set_model_kind (result
->ts
.kind
);
4646 mpfr_pow_ui (tmp
, e
->value
.real
, 2, GFC_RND_MODE
);
4647 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
4656 do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
4658 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4659 gcc_assert (result
->ts
.type
== BT_REAL
4660 && result
->expr_type
== EXPR_CONSTANT
);
4662 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
4663 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4669 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
4673 if (!is_constant_array_expr (e
)
4674 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
4677 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4678 init_result_expr (result
, 0, NULL
);
4680 if (!dim
|| e
->rank
== 1)
4682 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
4684 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4687 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
4688 add_squared
, &do_sqrt
);
4695 gfc_simplify_not (gfc_expr
*e
)
4699 if (e
->expr_type
!= EXPR_CONSTANT
)
4702 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4703 mpz_com (result
->value
.integer
, e
->value
.integer
);
4705 return range_check (result
, "NOT");
4710 gfc_simplify_null (gfc_expr
*mold
)
4716 result
= gfc_copy_expr (mold
);
4717 result
->expr_type
= EXPR_NULL
;
4720 result
= gfc_get_null_expr (NULL
);
4727 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
4731 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4733 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4734 return &gfc_bad_expr
;
4737 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
4740 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
4743 /* FIXME: gfc_current_locus is wrong. */
4744 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
4745 &gfc_current_locus
);
4747 if (failed
&& failed
->value
.logical
!= 0)
4748 mpz_set_si (result
->value
.integer
, 0);
4750 mpz_set_si (result
->value
.integer
, 1);
4757 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
4762 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4765 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4770 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
4771 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4772 return range_check (result
, "OR");
4775 return gfc_get_logical_expr (kind
, &x
->where
,
4776 x
->value
.logical
|| y
->value
.logical
);
4784 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4787 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
4789 if (!is_constant_array_expr (array
)
4790 || !is_constant_array_expr (vector
)
4791 || (!gfc_is_constant_expr (mask
)
4792 && !is_constant_array_expr (mask
)))
4795 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
4796 if (array
->ts
.type
== BT_DERIVED
)
4797 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
4799 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
4800 vector_ctor
= vector
4801 ? gfc_constructor_first (vector
->value
.constructor
)
4804 if (mask
->expr_type
== EXPR_CONSTANT
4805 && mask
->value
.logical
)
4807 /* Copy all elements of ARRAY to RESULT. */
4810 gfc_constructor_append_expr (&result
->value
.constructor
,
4811 gfc_copy_expr (array_ctor
->expr
),
4814 array_ctor
= gfc_constructor_next (array_ctor
);
4815 vector_ctor
= gfc_constructor_next (vector_ctor
);
4818 else if (mask
->expr_type
== EXPR_ARRAY
)
4820 /* Copy only those elements of ARRAY to RESULT whose
4821 MASK equals .TRUE.. */
4822 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4825 if (mask_ctor
->expr
->value
.logical
)
4827 gfc_constructor_append_expr (&result
->value
.constructor
,
4828 gfc_copy_expr (array_ctor
->expr
),
4830 vector_ctor
= gfc_constructor_next (vector_ctor
);
4833 array_ctor
= gfc_constructor_next (array_ctor
);
4834 mask_ctor
= gfc_constructor_next (mask_ctor
);
4838 /* Append any left-over elements from VECTOR to RESULT. */
4841 gfc_constructor_append_expr (&result
->value
.constructor
,
4842 gfc_copy_expr (vector_ctor
->expr
),
4844 vector_ctor
= gfc_constructor_next (vector_ctor
);
4847 result
->shape
= gfc_get_shape (1);
4848 gfc_array_size (result
, &result
->shape
[0]);
4850 if (array
->ts
.type
== BT_CHARACTER
)
4851 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
4858 do_xor (gfc_expr
*result
, gfc_expr
*e
)
4860 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
4861 gcc_assert (result
->ts
.type
== BT_LOGICAL
4862 && result
->expr_type
== EXPR_CONSTANT
);
4864 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
4871 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
4873 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
4878 gfc_simplify_popcnt (gfc_expr
*e
)
4883 if (e
->expr_type
!= EXPR_CONSTANT
)
4886 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4888 /* Convert argument to unsigned, then count the '1' bits. */
4889 mpz_init_set (x
, e
->value
.integer
);
4890 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
4891 res
= mpz_popcount (x
);
4894 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
4899 gfc_simplify_poppar (gfc_expr
*e
)
4905 if (e
->expr_type
!= EXPR_CONSTANT
)
4908 popcnt
= gfc_simplify_popcnt (e
);
4909 gcc_assert (popcnt
);
4911 s
= gfc_extract_int (popcnt
, &i
);
4914 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
4919 gfc_simplify_precision (gfc_expr
*e
)
4921 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4922 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
4923 gfc_real_kinds
[i
].precision
);
4928 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
4930 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
4935 gfc_simplify_radix (gfc_expr
*e
)
4938 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4943 i
= gfc_integer_kinds
[i
].radix
;
4947 i
= gfc_real_kinds
[i
].radix
;
4954 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4959 gfc_simplify_range (gfc_expr
*e
)
4962 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
4967 i
= gfc_integer_kinds
[i
].range
;
4972 i
= gfc_real_kinds
[i
].range
;
4979 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
4984 gfc_simplify_rank (gfc_expr
*e
)
4990 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
4995 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
4997 gfc_expr
*result
= NULL
;
5000 if (e
->ts
.type
== BT_COMPLEX
)
5001 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
5003 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
5006 return &gfc_bad_expr
;
5008 if (e
->expr_type
!= EXPR_CONSTANT
)
5011 if (convert_boz (e
, kind
) == &gfc_bad_expr
)
5012 return &gfc_bad_expr
;
5014 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
5015 if (result
== &gfc_bad_expr
)
5016 return &gfc_bad_expr
;
5018 return range_check (result
, "REAL");
5023 gfc_simplify_realpart (gfc_expr
*e
)
5027 if (e
->expr_type
!= EXPR_CONSTANT
)
5030 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
5031 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
5033 return range_check (result
, "REALPART");
5037 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
5040 int i
, j
, len
, ncop
, nlen
;
5042 bool have_length
= false;
5044 /* If NCOPIES isn't a constant, there's nothing we can do. */
5045 if (n
->expr_type
!= EXPR_CONSTANT
)
5048 /* If NCOPIES is negative, it's an error. */
5049 if (mpz_sgn (n
->value
.integer
) < 0)
5051 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
5053 return &gfc_bad_expr
;
5056 /* If we don't know the character length, we can do no more. */
5057 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
5058 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5060 len
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
5063 else if (e
->expr_type
== EXPR_CONSTANT
5064 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
5066 len
= e
->value
.character
.length
;
5071 /* If the source length is 0, any value of NCOPIES is valid
5072 and everything behaves as if NCOPIES == 0. */
5075 mpz_set_ui (ncopies
, 0);
5077 mpz_set (ncopies
, n
->value
.integer
);
5079 /* Check that NCOPIES isn't too large. */
5085 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
5087 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5091 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
5092 e
->ts
.u
.cl
->length
->value
.integer
);
5096 mpz_init_set_si (mlen
, len
);
5097 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
5101 /* The check itself. */
5102 if (mpz_cmp (ncopies
, max
) > 0)
5105 mpz_clear (ncopies
);
5106 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
5108 return &gfc_bad_expr
;
5113 mpz_clear (ncopies
);
5115 /* For further simplification, we need the character string to be
5117 if (e
->expr_type
!= EXPR_CONSTANT
)
5121 (e
->ts
.u
.cl
->length
&&
5122 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
)) != 0)
5124 const char *res
= gfc_extract_int (n
, &ncop
);
5125 gcc_assert (res
== NULL
);
5131 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
5133 len
= e
->value
.character
.length
;
5136 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
5137 for (i
= 0; i
< ncop
; i
++)
5138 for (j
= 0; j
< len
; j
++)
5139 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
5141 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
5146 /* This one is a bear, but mainly has to do with shuffling elements. */
5149 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
5150 gfc_expr
*pad
, gfc_expr
*order_exp
)
5152 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
5153 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
5157 gfc_expr
*e
, *result
;
5159 /* Check that argument expression types are OK. */
5160 if (!is_constant_array_expr (source
)
5161 || !is_constant_array_expr (shape_exp
)
5162 || !is_constant_array_expr (pad
)
5163 || !is_constant_array_expr (order_exp
))
5166 if (source
->shape
== NULL
)
5169 /* Proceed with simplification, unpacking the array. */
5176 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
5180 gfc_extract_int (e
, &shape
[rank
]);
5182 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
5183 gcc_assert (shape
[rank
] >= 0);
5188 gcc_assert (rank
> 0);
5190 /* Now unpack the order array if present. */
5191 if (order_exp
== NULL
)
5193 for (i
= 0; i
< rank
; i
++)
5198 for (i
= 0; i
< rank
; i
++)
5201 for (i
= 0; i
< rank
; i
++)
5203 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
5206 gfc_extract_int (e
, &order
[i
]);
5208 gcc_assert (order
[i
] >= 1 && order
[i
] <= rank
);
5210 gcc_assert (x
[order
[i
]] == 0);
5215 /* Count the elements in the source and padding arrays. */
5220 gfc_array_size (pad
, &size
);
5221 npad
= mpz_get_ui (size
);
5225 gfc_array_size (source
, &size
);
5226 nsource
= mpz_get_ui (size
);
5229 /* If it weren't for that pesky permutation we could just loop
5230 through the source and round out any shortage with pad elements.
5231 But no, someone just had to have the compiler do something the
5232 user should be doing. */
5234 for (i
= 0; i
< rank
; i
++)
5237 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
5239 if (source
->ts
.type
== BT_DERIVED
)
5240 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
5241 result
->rank
= rank
;
5242 result
->shape
= gfc_get_shape (rank
);
5243 for (i
= 0; i
< rank
; i
++)
5244 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
5246 while (nsource
> 0 || npad
> 0)
5248 /* Figure out which element to extract. */
5249 mpz_set_ui (index
, 0);
5251 for (i
= rank
- 1; i
>= 0; i
--)
5253 mpz_add_ui (index
, index
, x
[order
[i
]]);
5255 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
5258 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
5259 gfc_internal_error ("Reshaped array too large at %C");
5261 j
= mpz_get_ui (index
);
5264 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
5274 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
5278 gfc_constructor_append_expr (&result
->value
.constructor
,
5279 gfc_copy_expr (e
), &e
->where
);
5281 /* Calculate the next element. */
5285 if (++x
[i
] < shape
[i
])
5301 gfc_simplify_rrspacing (gfc_expr
*x
)
5307 if (x
->expr_type
!= EXPR_CONSTANT
)
5310 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5312 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5314 /* RRSPACING(+/- 0.0) = 0.0 */
5315 if (mpfr_zero_p (x
->value
.real
))
5317 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5321 /* RRSPACING(inf) = NaN */
5322 if (mpfr_inf_p (x
->value
.real
))
5324 mpfr_set_nan (result
->value
.real
);
5328 /* RRSPACING(NaN) = same NaN */
5329 if (mpfr_nan_p (x
->value
.real
))
5331 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5335 /* | x * 2**(-e) | * 2**p. */
5336 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5337 e
= - (long int) mpfr_get_exp (x
->value
.real
);
5338 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
5340 p
= (long int) gfc_real_kinds
[i
].digits
;
5341 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
5343 return range_check (result
, "RRSPACING");
5348 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
5350 int k
, neg_flag
, power
, exp_range
;
5351 mpfr_t scale
, radix
;
5354 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5357 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5359 if (mpfr_zero_p (x
->value
.real
))
5361 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5365 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5367 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
5369 /* This check filters out values of i that would overflow an int. */
5370 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
5371 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
5373 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
5374 gfc_free_expr (result
);
5375 return &gfc_bad_expr
;
5378 /* Compute scale = radix ** power. */
5379 power
= mpz_get_si (i
->value
.integer
);
5389 gfc_set_model_kind (x
->ts
.kind
);
5392 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
5393 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
5396 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5398 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5400 mpfr_clears (scale
, radix
, NULL
);
5402 return range_check (result
, "SCALE");
5406 /* Variants of strspn and strcspn that operate on wide characters. */
5409 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5412 const gfc_char_t
*c
;
5416 for (c
= s2
; *c
; c
++)
5430 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5433 const gfc_char_t
*c
;
5437 for (c
= s2
; *c
; c
++)
5452 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
5457 size_t indx
, len
, lenc
;
5458 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
5461 return &gfc_bad_expr
;
5463 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
5464 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
5467 if (b
!= NULL
&& b
->value
.logical
!= 0)
5472 len
= e
->value
.character
.length
;
5473 lenc
= c
->value
.character
.length
;
5475 if (len
== 0 || lenc
== 0)
5483 indx
= wide_strcspn (e
->value
.character
.string
,
5484 c
->value
.character
.string
) + 1;
5491 for (indx
= len
; indx
> 0; indx
--)
5493 for (i
= 0; i
< lenc
; i
++)
5495 if (c
->value
.character
.string
[i
]
5496 == e
->value
.character
.string
[indx
- 1])
5505 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
5506 return range_check (result
, "SCAN");
5511 gfc_simplify_selected_char_kind (gfc_expr
*e
)
5515 if (e
->expr_type
!= EXPR_CONSTANT
)
5518 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
5519 || gfc_compare_with_Cstring (e
, "default", false) == 0)
5521 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
5526 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5531 gfc_simplify_selected_int_kind (gfc_expr
*e
)
5535 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
5540 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
5541 if (gfc_integer_kinds
[i
].range
>= range
5542 && gfc_integer_kinds
[i
].kind
< kind
)
5543 kind
= gfc_integer_kinds
[i
].kind
;
5545 if (kind
== INT_MAX
)
5548 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5553 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
5555 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
5557 locus
*loc
= &gfc_current_locus
;
5563 if (p
->expr_type
!= EXPR_CONSTANT
5564 || gfc_extract_int (p
, &precision
) != NULL
)
5573 if (q
->expr_type
!= EXPR_CONSTANT
5574 || gfc_extract_int (q
, &range
) != NULL
)
5585 if (rdx
->expr_type
!= EXPR_CONSTANT
5586 || gfc_extract_int (rdx
, &radix
) != NULL
)
5594 found_precision
= 0;
5598 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5600 if (gfc_real_kinds
[i
].precision
>= precision
)
5601 found_precision
= 1;
5603 if (gfc_real_kinds
[i
].range
>= range
)
5606 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5609 if (gfc_real_kinds
[i
].precision
>= precision
5610 && gfc_real_kinds
[i
].range
>= range
5611 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5612 && gfc_real_kinds
[i
].kind
< kind
)
5613 kind
= gfc_real_kinds
[i
].kind
;
5616 if (kind
== INT_MAX
)
5618 if (found_radix
&& found_range
&& !found_precision
)
5620 else if (found_radix
&& found_precision
&& !found_range
)
5622 else if (found_radix
&& !found_precision
&& !found_range
)
5624 else if (found_radix
)
5630 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
5635 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5638 mpfr_t exp
, absv
, log2
, pow2
, frac
;
5641 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5644 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5646 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
5647 SET_EXPONENT (NaN) = same NaN */
5648 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
5650 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5654 /* SET_EXPONENT (inf) = NaN */
5655 if (mpfr_inf_p (x
->value
.real
))
5657 mpfr_set_nan (result
->value
.real
);
5661 gfc_set_model_kind (x
->ts
.kind
);
5668 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
5669 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
5671 mpfr_trunc (log2
, log2
);
5672 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
5674 /* Old exponent value, and fraction. */
5675 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
5677 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
5680 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
5681 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
5683 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
5685 return range_check (result
, "SET_EXPONENT");
5690 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
5692 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5693 gfc_expr
*result
, *e
, *f
;
5697 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
5699 if (source
->rank
== -1)
5702 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
5704 if (source
->rank
== 0)
5707 if (source
->expr_type
== EXPR_VARIABLE
)
5709 ar
= gfc_find_array_ref (source
);
5710 t
= gfc_array_ref_shape (ar
, shape
);
5712 else if (source
->shape
)
5715 for (n
= 0; n
< source
->rank
; n
++)
5717 mpz_init (shape
[n
]);
5718 mpz_set (shape
[n
], source
->shape
[n
]);
5724 for (n
= 0; n
< source
->rank
; n
++)
5726 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
5729 mpz_set (e
->value
.integer
, shape
[n
]);
5732 mpz_set_ui (e
->value
.integer
, n
+ 1);
5734 f
= simplify_size (source
, e
, k
);
5738 gfc_free_expr (result
);
5745 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
5747 gfc_free_expr (result
);
5749 gfc_clear_shape (shape
, source
->rank
);
5750 return &gfc_bad_expr
;
5753 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
5757 gfc_clear_shape (shape
, source
->rank
);
5764 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
5767 gfc_expr
*return_value
;
5770 /* For unary operations, the size of the result is given by the size
5771 of the operand. For binary ones, it's the size of the first operand
5772 unless it is scalar, then it is the size of the second. */
5773 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
5775 gfc_expr
* replacement
;
5776 gfc_expr
* simplified
;
5778 switch (array
->value
.op
.op
)
5780 /* Unary operations. */
5782 case INTRINSIC_UPLUS
:
5783 case INTRINSIC_UMINUS
:
5784 case INTRINSIC_PARENTHESES
:
5785 replacement
= array
->value
.op
.op1
;
5788 /* Binary operations. If any one of the operands is scalar, take
5789 the other one's size. If both of them are arrays, it does not
5790 matter -- try to find one with known shape, if possible. */
5792 if (array
->value
.op
.op1
->rank
== 0)
5793 replacement
= array
->value
.op
.op2
;
5794 else if (array
->value
.op
.op2
->rank
== 0)
5795 replacement
= array
->value
.op
.op1
;
5798 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
5802 replacement
= array
->value
.op
.op2
;
5807 /* Try to reduce it directly if possible. */
5808 simplified
= simplify_size (replacement
, dim
, k
);
5810 /* Otherwise, we build a new SIZE call. This is hopefully at least
5811 simpler than the original one. */
5814 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
5815 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
5816 GFC_ISYM_SIZE
, "size",
5818 gfc_copy_expr (replacement
),
5819 gfc_copy_expr (dim
),
5827 if (!gfc_array_size (array
, &size
))
5832 if (dim
->expr_type
!= EXPR_CONSTANT
)
5835 d
= mpz_get_ui (dim
->value
.integer
) - 1;
5836 if (!gfc_array_dimen_size (array
, d
, &size
))
5840 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
5841 mpz_set (return_value
->value
.integer
, size
);
5844 return return_value
;
5849 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
5852 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
5855 return &gfc_bad_expr
;
5857 result
= simplify_size (array
, dim
, k
);
5858 if (result
== NULL
|| result
== &gfc_bad_expr
)
5861 return range_check (result
, "SIZE");
5865 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
5866 multiplied by the array size. */
5869 gfc_simplify_sizeof (gfc_expr
*x
)
5871 gfc_expr
*result
= NULL
;
5874 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
5877 if (x
->ts
.type
== BT_CHARACTER
5878 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
5879 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
5882 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
5883 && !gfc_array_size (x
, &array_size
))
5886 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
5888 mpz_set_si (result
->value
.integer
, gfc_target_expr_size (x
));
5894 /* STORAGE_SIZE returns the size in bits of a single array element. */
5897 gfc_simplify_storage_size (gfc_expr
*x
,
5900 gfc_expr
*result
= NULL
;
5903 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
5906 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
5907 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
5908 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
5911 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
5913 return &gfc_bad_expr
;
5915 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
5917 mpz_set_si (result
->value
.integer
, gfc_element_size (x
));
5918 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
5920 return range_check (result
, "STORAGE_SIZE");
5925 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
5929 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
5932 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5937 mpz_abs (result
->value
.integer
, x
->value
.integer
);
5938 if (mpz_sgn (y
->value
.integer
) < 0)
5939 mpz_neg (result
->value
.integer
, result
->value
.integer
);
5944 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
5947 mpfr_setsign (result
->value
.real
, x
->value
.real
,
5948 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
5952 gfc_internal_error ("Bad type in gfc_simplify_sign");
5960 gfc_simplify_sin (gfc_expr
*x
)
5964 if (x
->expr_type
!= EXPR_CONSTANT
)
5967 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
5972 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5976 gfc_set_model (x
->value
.real
);
5977 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
5981 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
5984 return range_check (result
, "SIN");
5989 gfc_simplify_sinh (gfc_expr
*x
)
5993 if (x
->expr_type
!= EXPR_CONSTANT
)
5996 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6001 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6005 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6012 return range_check (result
, "SINH");
6016 /* The argument is always a double precision real that is converted to
6017 single precision. TODO: Rounding! */
6020 gfc_simplify_sngl (gfc_expr
*a
)
6024 if (a
->expr_type
!= EXPR_CONSTANT
)
6027 result
= gfc_real2real (a
, gfc_default_real_kind
);
6028 return range_check (result
, "SNGL");
6033 gfc_simplify_spacing (gfc_expr
*x
)
6039 if (x
->expr_type
!= EXPR_CONSTANT
)
6042 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
6043 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
6045 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
6046 if (mpfr_zero_p (x
->value
.real
))
6048 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6052 /* SPACING(inf) = NaN */
6053 if (mpfr_inf_p (x
->value
.real
))
6055 mpfr_set_nan (result
->value
.real
);
6059 /* SPACING(NaN) = same NaN */
6060 if (mpfr_nan_p (x
->value
.real
))
6062 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6066 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
6067 are the radix, exponent of x, and precision. This excludes the
6068 possibility of subnormal numbers. Fortran 2003 states the result is
6069 b**max(e - p, emin - 1). */
6071 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
6072 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
6073 en
= en
> ep
? en
: ep
;
6075 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
6076 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
6078 return range_check (result
, "SPACING");
6083 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
6085 gfc_expr
*result
= NULL
;
6086 int nelem
, i
, j
, dim
, ncopies
;
6089 if ((!gfc_is_constant_expr (source
)
6090 && !is_constant_array_expr (source
))
6091 || !gfc_is_constant_expr (dim_expr
)
6092 || !gfc_is_constant_expr (ncopies_expr
))
6095 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
6096 gfc_extract_int (dim_expr
, &dim
);
6097 dim
-= 1; /* zero-base DIM */
6099 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
6100 gfc_extract_int (ncopies_expr
, &ncopies
);
6101 ncopies
= MAX (ncopies
, 0);
6103 /* Do not allow the array size to exceed the limit for an array
6105 if (source
->expr_type
== EXPR_ARRAY
)
6107 if (!gfc_array_size (source
, &size
))
6108 gfc_internal_error ("Failure getting length of a constant array.");
6111 mpz_init_set_ui (size
, 1);
6113 nelem
= mpz_get_si (size
) * ncopies
;
6114 if (nelem
> flag_max_array_constructor
)
6116 if (gfc_current_ns
->sym_root
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
6118 gfc_error ("The number of elements (%d) in the array constructor "
6119 "at %L requires an increase of the allowed %d upper "
6120 "limit. See %<-fmax-array-constructor%> option.",
6121 nelem
, &source
->where
, flag_max_array_constructor
);
6122 return &gfc_bad_expr
;
6128 if (source
->expr_type
== EXPR_CONSTANT
)
6130 gcc_assert (dim
== 0);
6132 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6134 if (source
->ts
.type
== BT_DERIVED
)
6135 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6137 result
->shape
= gfc_get_shape (result
->rank
);
6138 mpz_init_set_si (result
->shape
[0], ncopies
);
6140 for (i
= 0; i
< ncopies
; ++i
)
6141 gfc_constructor_append_expr (&result
->value
.constructor
,
6142 gfc_copy_expr (source
), NULL
);
6144 else if (source
->expr_type
== EXPR_ARRAY
)
6146 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
6147 gfc_constructor
*source_ctor
;
6149 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
6150 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
6152 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6154 if (source
->ts
.type
== BT_DERIVED
)
6155 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6156 result
->rank
= source
->rank
+ 1;
6157 result
->shape
= gfc_get_shape (result
->rank
);
6159 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
6162 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
6164 mpz_init_set_si (result
->shape
[i
], ncopies
);
6166 extent
[i
] = mpz_get_si (result
->shape
[i
]);
6167 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
6171 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
6172 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
6174 for (i
= 0; i
< ncopies
; ++i
)
6175 gfc_constructor_insert_expr (&result
->value
.constructor
,
6176 gfc_copy_expr (source_ctor
->expr
),
6177 NULL
, offset
+ i
* rstride
[dim
]);
6179 offset
+= (dim
== 0 ? ncopies
: 1);
6184 gfc_error ("Simplification of SPREAD at %L not yet implemented",
6186 return &gfc_bad_expr
;
6189 if (source
->ts
.type
== BT_CHARACTER
)
6190 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
6197 gfc_simplify_sqrt (gfc_expr
*e
)
6199 gfc_expr
*result
= NULL
;
6201 if (e
->expr_type
!= EXPR_CONSTANT
)
6207 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
6209 gfc_error ("Argument of SQRT at %L has a negative value",
6211 return &gfc_bad_expr
;
6213 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6214 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6218 gfc_set_model (e
->value
.real
);
6220 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6221 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
6225 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
6228 return range_check (result
, "SQRT");
6233 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6235 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
6240 gfc_simplify_tan (gfc_expr
*x
)
6244 if (x
->expr_type
!= EXPR_CONSTANT
)
6247 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6252 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6256 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6263 return range_check (result
, "TAN");
6268 gfc_simplify_tanh (gfc_expr
*x
)
6272 if (x
->expr_type
!= EXPR_CONSTANT
)
6275 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6280 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6284 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6291 return range_check (result
, "TANH");
6296 gfc_simplify_tiny (gfc_expr
*e
)
6301 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
6303 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6304 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6311 gfc_simplify_trailz (gfc_expr
*e
)
6313 unsigned long tz
, bs
;
6316 if (e
->expr_type
!= EXPR_CONSTANT
)
6319 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6320 bs
= gfc_integer_kinds
[i
].bit_size
;
6321 tz
= mpz_scan1 (e
->value
.integer
, 0);
6323 return gfc_get_int_expr (gfc_default_integer_kind
,
6324 &e
->where
, MIN (tz
, bs
));
6329 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6332 gfc_expr
*mold_element
;
6337 unsigned char *buffer
;
6338 size_t result_length
;
6341 if (!gfc_is_constant_expr (source
)
6342 || (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
6343 || !gfc_is_constant_expr (size
))
6346 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6347 &result_size
, &result_length
))
6350 /* Calculate the size of the source. */
6351 if (source
->expr_type
== EXPR_ARRAY
6352 && !gfc_array_size (source
, &tmp
))
6353 gfc_internal_error ("Failure getting length of a constant array.");
6355 /* Create an empty new expression with the appropriate characteristics. */
6356 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
6358 result
->ts
= mold
->ts
;
6360 mold_element
= mold
->expr_type
== EXPR_ARRAY
6361 ? gfc_constructor_first (mold
->value
.constructor
)->expr
6364 /* Set result character length, if needed. Note that this needs to be
6365 set even for array expressions, in order to pass this information into
6366 gfc_target_interpret_expr. */
6367 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
6368 result
->value
.character
.length
= mold_element
->value
.character
.length
;
6370 /* Set the number of elements in the result, and determine its size. */
6372 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
6374 result
->expr_type
= EXPR_ARRAY
;
6376 result
->shape
= gfc_get_shape (1);
6377 mpz_init_set_ui (result
->shape
[0], result_length
);
6382 /* Allocate the buffer to store the binary version of the source. */
6383 buffer_size
= MAX (source_size
, result_size
);
6384 buffer
= (unsigned char*)alloca (buffer_size
);
6385 memset (buffer
, 0, buffer_size
);
6387 /* Now write source to the buffer. */
6388 gfc_target_encode_expr (source
, buffer
, buffer_size
);
6390 /* And read the buffer back into the new expression. */
6391 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
6398 gfc_simplify_transpose (gfc_expr
*matrix
)
6400 int row
, matrix_rows
, col
, matrix_cols
;
6403 if (!is_constant_array_expr (matrix
))
6406 gcc_assert (matrix
->rank
== 2);
6408 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
6411 result
->shape
= gfc_get_shape (result
->rank
);
6412 mpz_set (result
->shape
[0], matrix
->shape
[1]);
6413 mpz_set (result
->shape
[1], matrix
->shape
[0]);
6415 if (matrix
->ts
.type
== BT_CHARACTER
)
6416 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
6417 else if (matrix
->ts
.type
== BT_DERIVED
)
6418 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
6420 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
6421 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
6422 for (row
= 0; row
< matrix_rows
; ++row
)
6423 for (col
= 0; col
< matrix_cols
; ++col
)
6425 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
6426 col
* matrix_rows
+ row
);
6427 gfc_constructor_insert_expr (&result
->value
.constructor
,
6428 gfc_copy_expr (e
), &matrix
->where
,
6429 row
* matrix_cols
+ col
);
6437 gfc_simplify_trim (gfc_expr
*e
)
6440 int count
, i
, len
, lentrim
;
6442 if (e
->expr_type
!= EXPR_CONSTANT
)
6445 len
= e
->value
.character
.length
;
6446 for (count
= 0, i
= 1; i
<= len
; ++i
)
6448 if (e
->value
.character
.string
[len
- i
] == ' ')
6454 lentrim
= len
- count
;
6456 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
6457 for (i
= 0; i
< lentrim
; i
++)
6458 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
6465 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
6470 gfc_constructor
*sub_cons
;
6474 if (!is_constant_array_expr (sub
))
6477 /* Follow any component references. */
6478 as
= coarray
->symtree
->n
.sym
->as
;
6479 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
6480 if (ref
->type
== REF_COMPONENT
)
6483 if (as
->type
== AS_DEFERRED
)
6486 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6487 the cosubscript addresses the first image. */
6489 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
6492 for (d
= 1; d
<= as
->corank
; d
++)
6497 gcc_assert (sub_cons
!= NULL
);
6499 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
6501 if (ca_bound
== NULL
)
6504 if (ca_bound
== &gfc_bad_expr
)
6507 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
6511 gfc_free_expr (ca_bound
);
6512 sub_cons
= gfc_constructor_next (sub_cons
);
6516 first_image
= false;
6520 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6521 "SUB has %ld and COARRAY lower bound is %ld)",
6523 mpz_get_si (sub_cons
->expr
->value
.integer
),
6524 mpz_get_si (ca_bound
->value
.integer
));
6525 gfc_free_expr (ca_bound
);
6526 return &gfc_bad_expr
;
6529 gfc_free_expr (ca_bound
);
6531 /* Check whether upperbound is valid for the multi-images case. */
6534 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
6536 if (ca_bound
== &gfc_bad_expr
)
6539 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
6540 && mpz_cmp (ca_bound
->value
.integer
,
6541 sub_cons
->expr
->value
.integer
) < 0)
6543 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6544 "SUB has %ld and COARRAY upper bound is %ld)",
6546 mpz_get_si (sub_cons
->expr
->value
.integer
),
6547 mpz_get_si (ca_bound
->value
.integer
));
6548 gfc_free_expr (ca_bound
);
6549 return &gfc_bad_expr
;
6553 gfc_free_expr (ca_bound
);
6556 sub_cons
= gfc_constructor_next (sub_cons
);
6559 gcc_assert (sub_cons
== NULL
);
6561 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
6564 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6565 &gfc_current_locus
);
6567 mpz_set_si (result
->value
.integer
, 1);
6569 mpz_set_si (result
->value
.integer
, 0);
6576 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
6577 gfc_expr
*distance ATTRIBUTE_UNUSED
)
6579 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6582 /* If no coarray argument has been passed or when the first argument
6583 is actually a distance argment. */
6584 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
6587 /* FIXME: gfc_current_locus is wrong. */
6588 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6589 &gfc_current_locus
);
6590 mpz_set_si (result
->value
.integer
, 1);
6594 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
6595 return simplify_cobound (coarray
, dim
, NULL
, 0);
6600 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6602 return simplify_bound (array
, dim
, kind
, 1);
6606 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6608 return simplify_cobound (array
, dim
, kind
, 1);
6613 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6615 gfc_expr
*result
, *e
;
6616 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
6618 if (!is_constant_array_expr (vector
)
6619 || !is_constant_array_expr (mask
)
6620 || (!gfc_is_constant_expr (field
)
6621 && !is_constant_array_expr (field
)))
6624 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
6626 if (vector
->ts
.type
== BT_DERIVED
)
6627 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
6628 result
->rank
= mask
->rank
;
6629 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
6631 if (vector
->ts
.type
== BT_CHARACTER
)
6632 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
6634 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
6635 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6637 = field
->expr_type
== EXPR_ARRAY
6638 ? gfc_constructor_first (field
->value
.constructor
)
6643 if (mask_ctor
->expr
->value
.logical
)
6645 gcc_assert (vector_ctor
);
6646 e
= gfc_copy_expr (vector_ctor
->expr
);
6647 vector_ctor
= gfc_constructor_next (vector_ctor
);
6649 else if (field
->expr_type
== EXPR_ARRAY
)
6650 e
= gfc_copy_expr (field_ctor
->expr
);
6652 e
= gfc_copy_expr (field
);
6654 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
6656 mask_ctor
= gfc_constructor_next (mask_ctor
);
6657 field_ctor
= gfc_constructor_next (field_ctor
);
6665 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
6669 size_t index
, len
, lenset
;
6671 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
6674 return &gfc_bad_expr
;
6676 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
6677 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
6680 if (b
!= NULL
&& b
->value
.logical
!= 0)
6685 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
6687 len
= s
->value
.character
.length
;
6688 lenset
= set
->value
.character
.length
;
6692 mpz_set_ui (result
->value
.integer
, 0);
6700 mpz_set_ui (result
->value
.integer
, 1);
6704 index
= wide_strspn (s
->value
.character
.string
,
6705 set
->value
.character
.string
) + 1;
6714 mpz_set_ui (result
->value
.integer
, len
);
6717 for (index
= len
; index
> 0; index
--)
6719 for (i
= 0; i
< lenset
; i
++)
6721 if (s
->value
.character
.string
[index
- 1]
6722 == set
->value
.character
.string
[i
])
6730 mpz_set_ui (result
->value
.integer
, index
);
6736 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
6741 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6744 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6749 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6750 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6751 return range_check (result
, "XOR");
6754 return gfc_get_logical_expr (kind
, &x
->where
,
6755 (x
->value
.logical
&& !y
->value
.logical
)
6756 || (!x
->value
.logical
&& y
->value
.logical
));
6764 /****************** Constant simplification *****************/
6766 /* Master function to convert one constant to another. While this is
6767 used as a simplification function, it requires the destination type
6768 and kind information which is supplied by a special case in
6772 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
6774 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
6789 f
= gfc_int2complex
;
6809 f
= gfc_real2complex
;
6820 f
= gfc_complex2int
;
6823 f
= gfc_complex2real
;
6826 f
= gfc_complex2complex
;
6852 f
= gfc_hollerith2int
;
6856 f
= gfc_hollerith2real
;
6860 f
= gfc_hollerith2complex
;
6864 f
= gfc_hollerith2character
;
6868 f
= gfc_hollerith2logical
;
6878 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6883 switch (e
->expr_type
)
6886 result
= f (e
, kind
);
6888 return &gfc_bad_expr
;
6892 if (!gfc_is_constant_expr (e
))
6895 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6896 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6897 result
->rank
= e
->rank
;
6899 for (c
= gfc_constructor_first (e
->value
.constructor
);
6900 c
; c
= gfc_constructor_next (c
))
6903 if (c
->iterator
== NULL
)
6904 tmp
= f (c
->expr
, kind
);
6907 g
= gfc_convert_constant (c
->expr
, type
, kind
);
6908 if (g
== &gfc_bad_expr
)
6910 gfc_free_expr (result
);
6918 gfc_free_expr (result
);
6922 gfc_constructor_append_expr (&result
->value
.constructor
,
6936 /* Function for converting character constants. */
6938 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
6943 if (!gfc_is_constant_expr (e
))
6946 if (e
->expr_type
== EXPR_CONSTANT
)
6948 /* Simple case of a scalar. */
6949 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
6951 return &gfc_bad_expr
;
6953 result
->value
.character
.length
= e
->value
.character
.length
;
6954 result
->value
.character
.string
6955 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
6956 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
6957 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
6959 /* Check we only have values representable in the destination kind. */
6960 for (i
= 0; i
< result
->value
.character
.length
; i
++)
6961 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
6964 gfc_error ("Character %qs in string at %L cannot be converted "
6965 "into character kind %d",
6966 gfc_print_wide_char (result
->value
.character
.string
[i
]),
6968 return &gfc_bad_expr
;
6973 else if (e
->expr_type
== EXPR_ARRAY
)
6975 /* For an array constructor, we convert each constructor element. */
6978 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
6979 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
6980 result
->rank
= e
->rank
;
6981 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
6983 for (c
= gfc_constructor_first (e
->value
.constructor
);
6984 c
; c
= gfc_constructor_next (c
))
6986 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
6987 if (tmp
== &gfc_bad_expr
)
6989 gfc_free_expr (result
);
6990 return &gfc_bad_expr
;
6995 gfc_free_expr (result
);
6999 gfc_constructor_append_expr (&result
->value
.constructor
,
7011 gfc_simplify_compiler_options (void)
7016 str
= gfc_get_option_string ();
7017 result
= gfc_get_character_expr (gfc_default_character_kind
,
7018 &gfc_current_locus
, str
, strlen (str
));
7025 gfc_simplify_compiler_version (void)
7030 len
= strlen ("GCC version ") + strlen (version_string
);
7031 buffer
= XALLOCAVEC (char, len
+ 1);
7032 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
7033 return gfc_get_character_expr (gfc_default_character_kind
,
7034 &gfc_current_locus
, buffer
, len
);
7037 /* Simplification routines for intrinsics of IEEE modules. */
7040 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
7042 gfc_actual_arglist
*arg
= expr
->value
.function
.actual
;
7043 gfc_expr
*p
= arg
->expr
, *q
= arg
->next
->expr
,
7044 *rdx
= arg
->next
->next
->expr
;
7046 /* Currently, if IEEE is supported and this module is built, it means
7047 all our floating-point types conform to IEEE. Hence, we simply handle
7048 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
7049 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
7053 simplify_ieee_support (gfc_expr
*expr
)
7055 /* We consider that if the IEEE modules are loaded, we have full support
7056 for flags, halting and rounding, which are the three functions
7057 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
7058 expressions. One day, we will need libgfortran to detect support and
7059 communicate it back to us, allowing for partial support. */
7061 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
7066 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
7068 int n
= strlen(name
);
7070 if (!strncmp(sym
->name
, name
, n
))
7073 /* If a generic was used and renamed, we need more work to find out.
7074 Compare the specific name. */
7075 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
7082 gfc_simplify_ieee_functions (gfc_expr
*expr
)
7084 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
7086 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
7087 return simplify_ieee_selected_real_kind (expr
);
7088 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
7089 || matches_ieee_function_name(sym
, "ieee_support_halting")
7090 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
7091 return simplify_ieee_support (expr
);