1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2017 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
));
499 /* Transforms an ARRAY with operation OP, according to MASK, to an
500 array RESULT. E.g. called if
502 REAL, PARAMETER :: array(n, m) = ...
503 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
505 where OP == gfc_multiply().
506 The result might be post processed using post_op. */
509 simplify_transformation_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*dim
,
510 gfc_expr
*mask
, transformational_op op
,
511 transformational_op post_op
)
514 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
515 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
516 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
518 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
519 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
520 tmpstride
[GFC_MAX_DIMENSIONS
];
522 /* Shortcut for constant .FALSE. MASK. */
524 && mask
->expr_type
== EXPR_CONSTANT
525 && !mask
->value
.logical
)
528 /* Build an indexed table for array element expressions to minimize
529 linked-list traversal. Masked elements are set to NULL. */
530 gfc_array_size (array
, &size
);
531 arraysize
= mpz_get_ui (size
);
534 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
536 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
538 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
539 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
541 for (i
= 0; i
< arraysize
; ++i
)
543 arrayvec
[i
] = array_ctor
->expr
;
544 array_ctor
= gfc_constructor_next (array_ctor
);
548 if (!mask_ctor
->expr
->value
.logical
)
551 mask_ctor
= gfc_constructor_next (mask_ctor
);
555 /* Same for the result expression. */
556 gfc_array_size (result
, &size
);
557 resultsize
= mpz_get_ui (size
);
560 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
561 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
562 for (i
= 0; i
< resultsize
; ++i
)
564 resultvec
[i
] = result_ctor
->expr
;
565 result_ctor
= gfc_constructor_next (result_ctor
);
568 gfc_extract_int (dim
, &dim_index
);
569 dim_index
-= 1; /* zero-base index */
573 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
576 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
579 dim_extent
= mpz_get_si (array
->shape
[i
]);
580 dim_stride
= tmpstride
[i
];
584 extent
[n
] = mpz_get_si (array
->shape
[i
]);
585 sstride
[n
] = tmpstride
[i
];
586 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
595 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
597 *dest
= op (*dest
, gfc_copy_expr (*src
));
604 while (!done
&& count
[n
] == extent
[n
])
607 base
-= sstride
[n
] * extent
[n
];
608 dest
-= dstride
[n
] * extent
[n
];
611 if (n
< result
->rank
)
622 /* Place updated expression in result constructor. */
623 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
624 for (i
= 0; i
< resultsize
; ++i
)
627 result_ctor
->expr
= post_op (result_ctor
->expr
, resultvec
[i
]);
629 result_ctor
->expr
= resultvec
[i
];
630 result_ctor
= gfc_constructor_next (result_ctor
);
640 simplify_transformation (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
641 int init_val
, transformational_op op
)
645 if (!is_constant_array_expr (array
)
646 || !gfc_is_constant_expr (dim
))
650 && !is_constant_array_expr (mask
)
651 && mask
->expr_type
!= EXPR_CONSTANT
)
654 result
= transformational_result (array
, dim
, array
->ts
.type
,
655 array
->ts
.kind
, &array
->where
);
656 init_result_expr (result
, init_val
, NULL
);
658 return !dim
|| array
->rank
== 1 ?
659 simplify_transformation_to_scalar (result
, array
, mask
, op
) :
660 simplify_transformation_to_array (result
, array
, dim
, mask
, op
, NULL
);
664 /********************** Simplification functions *****************************/
667 gfc_simplify_abs (gfc_expr
*e
)
671 if (e
->expr_type
!= EXPR_CONSTANT
)
677 result
= gfc_get_constant_expr (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
678 mpz_abs (result
->value
.integer
, e
->value
.integer
);
679 return range_check (result
, "IABS");
682 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
683 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
684 return range_check (result
, "ABS");
687 gfc_set_model_kind (e
->ts
.kind
);
688 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
689 mpc_abs (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
690 return range_check (result
, "CABS");
693 gfc_internal_error ("gfc_simplify_abs(): Bad type");
699 simplify_achar_char (gfc_expr
*e
, gfc_expr
*k
, const char *name
, bool ascii
)
703 bool too_large
= false;
705 if (e
->expr_type
!= EXPR_CONSTANT
)
708 kind
= get_kind (BT_CHARACTER
, k
, name
, gfc_default_character_kind
);
710 return &gfc_bad_expr
;
712 if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
714 gfc_error ("Argument of %s function at %L is negative", name
,
716 return &gfc_bad_expr
;
719 if (ascii
&& warn_surprising
&& mpz_cmp_si (e
->value
.integer
, 127) > 0)
720 gfc_warning (OPT_Wsurprising
,
721 "Argument of %s function at %L outside of range [0,127]",
724 if (kind
== 1 && mpz_cmp_si (e
->value
.integer
, 255) > 0)
729 mpz_init_set_ui (t
, 2);
730 mpz_pow_ui (t
, t
, 32);
731 mpz_sub_ui (t
, t
, 1);
732 if (mpz_cmp (e
->value
.integer
, t
) > 0)
739 gfc_error ("Argument of %s function at %L is too large for the "
740 "collating sequence of kind %d", name
, &e
->where
, kind
);
741 return &gfc_bad_expr
;
744 result
= gfc_get_character_expr (kind
, &e
->where
, NULL
, 1);
745 result
->value
.character
.string
[0] = mpz_get_ui (e
->value
.integer
);
752 /* We use the processor's collating sequence, because all
753 systems that gfortran currently works on are ASCII. */
756 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
758 return simplify_achar_char (e
, k
, "ACHAR", true);
763 gfc_simplify_acos (gfc_expr
*x
)
767 if (x
->expr_type
!= EXPR_CONSTANT
)
773 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
774 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
776 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
778 return &gfc_bad_expr
;
780 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
781 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
785 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
786 mpc_acos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
790 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
793 return range_check (result
, "ACOS");
797 gfc_simplify_acosh (gfc_expr
*x
)
801 if (x
->expr_type
!= EXPR_CONSTANT
)
807 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
809 gfc_error ("Argument of ACOSH at %L must not be less than 1",
811 return &gfc_bad_expr
;
814 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
815 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
819 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
820 mpc_acosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
824 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
827 return range_check (result
, "ACOSH");
831 gfc_simplify_adjustl (gfc_expr
*e
)
837 if (e
->expr_type
!= EXPR_CONSTANT
)
840 len
= e
->value
.character
.length
;
842 for (count
= 0, i
= 0; i
< len
; ++i
)
844 ch
= e
->value
.character
.string
[i
];
850 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
851 for (i
= 0; i
< len
- count
; ++i
)
852 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
859 gfc_simplify_adjustr (gfc_expr
*e
)
865 if (e
->expr_type
!= EXPR_CONSTANT
)
868 len
= e
->value
.character
.length
;
870 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
872 ch
= e
->value
.character
.string
[i
];
878 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
879 for (i
= 0; i
< count
; ++i
)
880 result
->value
.character
.string
[i
] = ' ';
882 for (i
= count
; i
< len
; ++i
)
883 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
890 gfc_simplify_aimag (gfc_expr
*e
)
894 if (e
->expr_type
!= EXPR_CONSTANT
)
897 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
898 mpfr_set (result
->value
.real
, mpc_imagref (e
->value
.complex), GFC_RND_MODE
);
900 return range_check (result
, "AIMAG");
905 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
907 gfc_expr
*rtrunc
, *result
;
910 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
912 return &gfc_bad_expr
;
914 if (e
->expr_type
!= EXPR_CONSTANT
)
917 rtrunc
= gfc_copy_expr (e
);
918 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
920 result
= gfc_real2real (rtrunc
, kind
);
922 gfc_free_expr (rtrunc
);
924 return range_check (result
, "AINT");
929 gfc_simplify_all (gfc_expr
*mask
, gfc_expr
*dim
)
931 return simplify_transformation (mask
, dim
, NULL
, true, gfc_and
);
936 gfc_simplify_dint (gfc_expr
*e
)
938 gfc_expr
*rtrunc
, *result
;
940 if (e
->expr_type
!= EXPR_CONSTANT
)
943 rtrunc
= gfc_copy_expr (e
);
944 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
946 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
948 gfc_free_expr (rtrunc
);
950 return range_check (result
, "DINT");
955 gfc_simplify_dreal (gfc_expr
*e
)
957 gfc_expr
*result
= NULL
;
959 if (e
->expr_type
!= EXPR_CONSTANT
)
962 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
963 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
965 return range_check (result
, "DREAL");
970 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
975 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
977 return &gfc_bad_expr
;
979 if (e
->expr_type
!= EXPR_CONSTANT
)
982 result
= gfc_get_constant_expr (e
->ts
.type
, kind
, &e
->where
);
983 mpfr_round (result
->value
.real
, e
->value
.real
);
985 return range_check (result
, "ANINT");
990 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
995 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
998 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1003 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
1004 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1005 return range_check (result
, "AND");
1008 return gfc_get_logical_expr (kind
, &x
->where
,
1009 x
->value
.logical
&& y
->value
.logical
);
1018 gfc_simplify_any (gfc_expr
*mask
, gfc_expr
*dim
)
1020 return simplify_transformation (mask
, dim
, NULL
, false, gfc_or
);
1025 gfc_simplify_dnint (gfc_expr
*e
)
1029 if (e
->expr_type
!= EXPR_CONSTANT
)
1032 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &e
->where
);
1033 mpfr_round (result
->value
.real
, e
->value
.real
);
1035 return range_check (result
, "DNINT");
1040 gfc_simplify_asin (gfc_expr
*x
)
1044 if (x
->expr_type
!= EXPR_CONSTANT
)
1050 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1051 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1053 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1055 return &gfc_bad_expr
;
1057 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1058 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1062 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1063 mpc_asin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1067 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1070 return range_check (result
, "ASIN");
1075 gfc_simplify_asinh (gfc_expr
*x
)
1079 if (x
->expr_type
!= EXPR_CONSTANT
)
1082 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1087 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1091 mpc_asinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1095 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1098 return range_check (result
, "ASINH");
1103 gfc_simplify_atan (gfc_expr
*x
)
1107 if (x
->expr_type
!= EXPR_CONSTANT
)
1110 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1115 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1119 mpc_atan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1123 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1126 return range_check (result
, "ATAN");
1131 gfc_simplify_atanh (gfc_expr
*x
)
1135 if (x
->expr_type
!= EXPR_CONSTANT
)
1141 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
1142 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
1144 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1146 return &gfc_bad_expr
;
1148 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1149 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1153 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1154 mpc_atanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1158 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1161 return range_check (result
, "ATANH");
1166 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1170 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1173 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1175 gfc_error ("If first argument of ATAN2 %L is zero, then the "
1176 "second argument must not be zero", &x
->where
);
1177 return &gfc_bad_expr
;
1180 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1181 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1183 return range_check (result
, "ATAN2");
1188 gfc_simplify_bessel_j0 (gfc_expr
*x
)
1192 if (x
->expr_type
!= EXPR_CONSTANT
)
1195 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1196 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1198 return range_check (result
, "BESSEL_J0");
1203 gfc_simplify_bessel_j1 (gfc_expr
*x
)
1207 if (x
->expr_type
!= EXPR_CONSTANT
)
1210 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1211 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1213 return range_check (result
, "BESSEL_J1");
1218 gfc_simplify_bessel_jn (gfc_expr
*order
, gfc_expr
*x
)
1223 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1226 n
= mpz_get_si (order
->value
.integer
);
1227 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1228 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1230 return range_check (result
, "BESSEL_JN");
1234 /* Simplify transformational form of JN and YN. */
1237 gfc_simplify_bessel_n2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
,
1244 mpfr_t x2rev
, last1
, last2
;
1246 if (x
->expr_type
!= EXPR_CONSTANT
|| order1
->expr_type
!= EXPR_CONSTANT
1247 || order2
->expr_type
!= EXPR_CONSTANT
)
1250 n1
= mpz_get_si (order1
->value
.integer
);
1251 n2
= mpz_get_si (order2
->value
.integer
);
1252 result
= gfc_get_array_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1254 result
->shape
= gfc_get_shape (1);
1255 mpz_init_set_ui (result
->shape
[0], MAX (n2
-n1
+1, 0));
1260 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1261 YN(N, 0.0) = -Inf. */
1263 if (mpfr_cmp_ui (x
->value
.real
, 0.0) == 0)
1265 if (!jn
&& flag_range_check
)
1267 gfc_error ("Result of BESSEL_YN is -INF at %L", &result
->where
);
1268 gfc_free_expr (result
);
1269 return &gfc_bad_expr
;
1274 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1275 mpfr_set_ui (e
->value
.real
, 1, GFC_RND_MODE
);
1276 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1281 for (i
= n1
; i
<= n2
; i
++)
1283 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1285 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
1287 mpfr_set_inf (e
->value
.real
, -1);
1288 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1295 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1296 are stable for downward recursion and Neumann functions are stable
1297 for upward recursion. It is
1299 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1300 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1301 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1303 gfc_set_model_kind (x
->ts
.kind
);
1305 /* Get first recursion anchor. */
1309 mpfr_jn (last1
, n2
, x
->value
.real
, GFC_RND_MODE
);
1311 mpfr_yn (last1
, n1
, x
->value
.real
, GFC_RND_MODE
);
1313 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1314 mpfr_set (e
->value
.real
, last1
, GFC_RND_MODE
);
1315 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1319 gfc_free_expr (result
);
1320 return &gfc_bad_expr
;
1322 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1330 /* Get second recursion anchor. */
1334 mpfr_jn (last2
, n2
-1, x
->value
.real
, GFC_RND_MODE
);
1336 mpfr_yn (last2
, n1
+1, x
->value
.real
, GFC_RND_MODE
);
1338 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1339 mpfr_set (e
->value
.real
, last2
, GFC_RND_MODE
);
1340 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1345 gfc_free_expr (result
);
1346 return &gfc_bad_expr
;
1349 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
, -2);
1351 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1360 /* Start actual recursion. */
1363 mpfr_ui_div (x2rev
, 2, x
->value
.real
, GFC_RND_MODE
);
1365 for (i
= 2; i
<= n2
-n1
; i
++)
1367 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1369 /* Special case: For YN, if the previous N gave -INF, set
1370 also N+1 to -INF. */
1371 if (!jn
&& !flag_range_check
&& mpfr_inf_p (last2
))
1373 mpfr_set_inf (e
->value
.real
, -1);
1374 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1379 mpfr_mul_si (e
->value
.real
, x2rev
, jn
? (n2
-i
+1) : (n1
+i
-1),
1381 mpfr_mul (e
->value
.real
, e
->value
.real
, last2
, GFC_RND_MODE
);
1382 mpfr_sub (e
->value
.real
, e
->value
.real
, last1
, GFC_RND_MODE
);
1384 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1386 /* Range_check frees "e" in that case. */
1392 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
,
1395 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1397 mpfr_set (last1
, last2
, GFC_RND_MODE
);
1398 mpfr_set (last2
, e
->value
.real
, GFC_RND_MODE
);
1411 gfc_free_expr (result
);
1412 return &gfc_bad_expr
;
1417 gfc_simplify_bessel_jn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1419 return gfc_simplify_bessel_n2 (order1
, order2
, x
, true);
1424 gfc_simplify_bessel_y0 (gfc_expr
*x
)
1428 if (x
->expr_type
!= EXPR_CONSTANT
)
1431 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1432 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1434 return range_check (result
, "BESSEL_Y0");
1439 gfc_simplify_bessel_y1 (gfc_expr
*x
)
1443 if (x
->expr_type
!= EXPR_CONSTANT
)
1446 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1447 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1449 return range_check (result
, "BESSEL_Y1");
1454 gfc_simplify_bessel_yn (gfc_expr
*order
, gfc_expr
*x
)
1459 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1462 n
= mpz_get_si (order
->value
.integer
);
1463 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1464 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1466 return range_check (result
, "BESSEL_YN");
1471 gfc_simplify_bessel_yn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1473 return gfc_simplify_bessel_n2 (order1
, order2
, x
, false);
1478 gfc_simplify_bit_size (gfc_expr
*e
)
1480 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1481 return gfc_get_int_expr (e
->ts
.kind
, &e
->where
,
1482 gfc_integer_kinds
[i
].bit_size
);
1487 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
1491 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
1494 if (gfc_extract_int (bit
, &b
) != NULL
|| b
< 0)
1495 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
, false);
1497 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
,
1498 mpz_tstbit (e
->value
.integer
, b
));
1503 compare_bitwise (gfc_expr
*i
, gfc_expr
*j
)
1508 gcc_assert (i
->ts
.type
== BT_INTEGER
);
1509 gcc_assert (j
->ts
.type
== BT_INTEGER
);
1511 mpz_init_set (x
, i
->value
.integer
);
1512 k
= gfc_validate_kind (i
->ts
.type
, i
->ts
.kind
, false);
1513 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
1515 mpz_init_set (y
, j
->value
.integer
);
1516 k
= gfc_validate_kind (j
->ts
.type
, j
->ts
.kind
, false);
1517 convert_mpz_to_unsigned (y
, gfc_integer_kinds
[k
].bit_size
);
1519 res
= mpz_cmp (x
, y
);
1527 gfc_simplify_bge (gfc_expr
*i
, gfc_expr
*j
)
1529 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1532 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1533 compare_bitwise (i
, j
) >= 0);
1538 gfc_simplify_bgt (gfc_expr
*i
, gfc_expr
*j
)
1540 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1543 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1544 compare_bitwise (i
, j
) > 0);
1549 gfc_simplify_ble (gfc_expr
*i
, gfc_expr
*j
)
1551 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1554 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1555 compare_bitwise (i
, j
) <= 0);
1560 gfc_simplify_blt (gfc_expr
*i
, gfc_expr
*j
)
1562 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1565 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1566 compare_bitwise (i
, j
) < 0);
1571 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
1573 gfc_expr
*ceil
, *result
;
1576 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
1578 return &gfc_bad_expr
;
1580 if (e
->expr_type
!= EXPR_CONSTANT
)
1583 ceil
= gfc_copy_expr (e
);
1584 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
1586 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
1587 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
, &e
->where
);
1589 gfc_free_expr (ceil
);
1591 return range_check (result
, "CEILING");
1596 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
1598 return simplify_achar_char (e
, k
, "CHAR", false);
1602 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1605 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
1609 if (convert_boz (x
, kind
) == &gfc_bad_expr
)
1610 return &gfc_bad_expr
;
1612 if (convert_boz (y
, kind
) == &gfc_bad_expr
)
1613 return &gfc_bad_expr
;
1615 if (x
->expr_type
!= EXPR_CONSTANT
1616 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1619 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &x
->where
);
1624 mpc_set_z (result
->value
.complex, x
->value
.integer
, GFC_MPC_RND_MODE
);
1628 mpc_set_fr (result
->value
.complex, x
->value
.real
, GFC_RND_MODE
);
1632 mpc_set (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1636 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1640 return range_check (result
, name
);
1645 mpfr_set_z (mpc_imagref (result
->value
.complex),
1646 y
->value
.integer
, GFC_RND_MODE
);
1650 mpfr_set (mpc_imagref (result
->value
.complex),
1651 y
->value
.real
, GFC_RND_MODE
);
1655 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1658 return range_check (result
, name
);
1663 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
1667 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_complex_kind
);
1669 return &gfc_bad_expr
;
1671 return simplify_cmplx ("CMPLX", x
, y
, kind
);
1676 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
1680 if (x
->ts
.type
== BT_INTEGER
&& y
->ts
.type
== BT_INTEGER
)
1681 kind
= gfc_default_complex_kind
;
1682 else if (x
->ts
.type
== BT_REAL
|| y
->ts
.type
== BT_INTEGER
)
1684 else if (x
->ts
.type
== BT_INTEGER
|| y
->ts
.type
== BT_REAL
)
1686 else if (x
->ts
.type
== BT_REAL
&& y
->ts
.type
== BT_REAL
)
1687 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
1691 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1696 gfc_simplify_conjg (gfc_expr
*e
)
1700 if (e
->expr_type
!= EXPR_CONSTANT
)
1703 result
= gfc_copy_expr (e
);
1704 mpc_conj (result
->value
.complex, result
->value
.complex, GFC_MPC_RND_MODE
);
1706 return range_check (result
, "CONJG");
1709 /* Return the simplification of the constant expression in icall, or NULL
1710 if the expression is not constant. */
1713 simplify_trig_call (gfc_expr
*icall
)
1715 gfc_isym_id func
= icall
->value
.function
.isym
->id
;
1716 gfc_expr
*x
= icall
->value
.function
.actual
->expr
;
1718 /* The actual simplifiers will return NULL for non-constant x. */
1722 return gfc_simplify_acos (x
);
1724 return gfc_simplify_asin (x
);
1726 return gfc_simplify_atan (x
);
1728 return gfc_simplify_cos (x
);
1729 case GFC_ISYM_COTAN
:
1730 return gfc_simplify_cotan (x
);
1732 return gfc_simplify_sin (x
);
1734 return gfc_simplify_tan (x
);
1736 gfc_internal_error ("in simplify_trig_call(): Bad intrinsic");
1740 /* Convert a floating-point number from radians to degrees. */
1743 degrees_f (mpfr_t x
, mp_rnd_t rnd_mode
)
1748 /* Set x = x % 2pi to avoid offsets with large angles. */
1749 mpfr_const_pi (tmp
, rnd_mode
);
1750 mpfr_mul_ui (tmp
, tmp
, 2, rnd_mode
);
1751 mpfr_fmod (tmp
, x
, tmp
, rnd_mode
);
1753 /* Set x = x * 180. */
1754 mpfr_mul_ui (x
, x
, 180, rnd_mode
);
1756 /* Set x = x / pi. */
1757 mpfr_const_pi (tmp
, rnd_mode
);
1758 mpfr_div (x
, x
, tmp
, rnd_mode
);
1763 /* Convert a floating-point number from degrees to radians. */
1766 radians_f (mpfr_t x
, mp_rnd_t rnd_mode
)
1771 /* Set x = x % 360 to avoid offsets with large angles. */
1772 mpfr_set_ui (tmp
, 360, rnd_mode
);
1773 mpfr_fmod (tmp
, x
, tmp
, rnd_mode
);
1775 /* Set x = x * pi. */
1776 mpfr_const_pi (tmp
, rnd_mode
);
1777 mpfr_mul (x
, x
, tmp
, rnd_mode
);
1779 /* Set x = x / 180. */
1780 mpfr_div_ui (x
, x
, 180, rnd_mode
);
1786 /* Convert argument to radians before calling a trig function. */
1789 gfc_simplify_trigd (gfc_expr
*icall
)
1793 arg
= icall
->value
.function
.actual
->expr
;
1795 if (arg
->ts
.type
!= BT_REAL
)
1796 gfc_internal_error ("in gfc_simplify_trigd(): Bad type");
1798 if (arg
->expr_type
== EXPR_CONSTANT
)
1799 /* Convert constant to radians before passing off to simplifier. */
1800 radians_f (arg
->value
.real
, GFC_RND_MODE
);
1802 /* Let the usual simplifier take over - we just simplified the arg. */
1803 return simplify_trig_call (icall
);
1806 /* Convert result of an inverse trig function to degrees. */
1809 gfc_simplify_atrigd (gfc_expr
*icall
)
1813 if (icall
->value
.function
.actual
->expr
->ts
.type
!= BT_REAL
)
1814 gfc_internal_error ("in gfc_simplify_atrigd(): Bad type");
1816 /* See if another simplifier has work to do first. */
1817 result
= simplify_trig_call (icall
);
1819 if (result
&& result
->expr_type
== EXPR_CONSTANT
)
1821 /* Convert constant to degrees after passing off to actual simplifier. */
1822 degrees_f (result
->value
.real
, GFC_RND_MODE
);
1826 /* Let gfc_resolve_atrigd take care of the non-constant case. */
1830 /* Convert the result of atan2 to degrees. */
1833 gfc_simplify_atan2d (gfc_expr
*y
, gfc_expr
*x
)
1837 if (x
->ts
.type
!= BT_REAL
|| y
->ts
.type
!= BT_REAL
)
1838 gfc_internal_error ("in gfc_simplify_atan2d(): Bad type");
1840 if (x
->expr_type
== EXPR_CONSTANT
&& y
->expr_type
== EXPR_CONSTANT
)
1842 result
= gfc_simplify_atan2 (y
, x
);
1845 degrees_f (result
->value
.real
, GFC_RND_MODE
);
1850 /* Let gfc_resolve_atan2d take care of the non-constant case. */
1855 gfc_simplify_cos (gfc_expr
*x
)
1859 if (x
->expr_type
!= EXPR_CONSTANT
)
1862 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1867 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1871 gfc_set_model_kind (x
->ts
.kind
);
1872 mpc_cos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1876 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1879 return range_check (result
, "COS");
1884 gfc_simplify_cosh (gfc_expr
*x
)
1888 if (x
->expr_type
!= EXPR_CONSTANT
)
1891 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1896 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1900 mpc_cosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1907 return range_check (result
, "COSH");
1912 gfc_simplify_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1916 if (!is_constant_array_expr (mask
)
1917 || !gfc_is_constant_expr (dim
)
1918 || !gfc_is_constant_expr (kind
))
1921 result
= transformational_result (mask
, dim
,
1923 get_kind (BT_INTEGER
, kind
, "COUNT",
1924 gfc_default_integer_kind
),
1927 init_result_expr (result
, 0, NULL
);
1929 /* Passing MASK twice, once as data array, once as mask.
1930 Whenever gfc_count is called, '1' is added to the result. */
1931 return !dim
|| mask
->rank
== 1 ?
1932 simplify_transformation_to_scalar (result
, mask
, mask
, gfc_count
) :
1933 simplify_transformation_to_array (result
, mask
, dim
, mask
, gfc_count
, NULL
);
1938 gfc_simplify_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1940 gfc_expr
*a
, *result
;
1943 /* DIM is only useful for rank > 1, but deal with it here as one can
1944 set DIM = 1 for rank = 1. */
1947 if (!gfc_is_constant_expr (dim
))
1949 dm
= mpz_get_si (dim
->value
.integer
);
1954 /* Copy array into 'a', simplify it, and then test for a constant array. */
1955 a
= gfc_copy_expr (array
);
1956 gfc_simplify_expr (a
, 0);
1957 if (!is_constant_array_expr (a
))
1965 gfc_constructor
*ca
, *cr
;
1969 if (!gfc_is_constant_expr (shift
))
1975 shft
= mpz_get_si (shift
->value
.integer
);
1977 /* Case (i): If ARRAY has rank one, element i of the result is
1978 ARRAY (1 + MODULO (i + SHIFT - 1, SIZE (ARRAY))). */
1981 gfc_array_size (a
, &size
);
1982 sz
= mpz_get_si (size
);
1985 /* Adjust shft to deal with right or left shifts. */
1986 shft
= shft
< 0 ? 1 - shft
: shft
;
1988 /* Special case: Shift to the original order! */
1989 if (sz
== 0 || shft
% sz
== 0)
1992 result
= gfc_copy_expr (a
);
1993 cr
= gfc_constructor_first (result
->value
.constructor
);
1994 for (i
= 0; i
< sz
; i
++, cr
= gfc_constructor_next (cr
))
1996 j
= (i
+ shft
) % sz
;
1997 ca
= gfc_constructor_first (a
->value
.constructor
);
1999 ca
= gfc_constructor_next (ca
);
2000 cr
->expr
= gfc_copy_expr (ca
->expr
);
2008 /* FIXME: Deal with rank > 1 arrays. For now, don't leak memory. */
2010 /* GCC bootstrap is too stupid to realize that the above code for dm
2011 is correct. First, dim can be specified for a rank 1 array. It is
2012 not needed in this nor used here. Second, the code is simply waiting
2013 for someone to implement rank > 1 simplification. For now, add a
2014 pessimization to the code that has a zero valid reason to be here. */
2015 if (dm
> array
->rank
)
2026 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2028 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
2033 gfc_simplify_dble (gfc_expr
*e
)
2035 gfc_expr
*result
= NULL
;
2037 if (e
->expr_type
!= EXPR_CONSTANT
)
2040 if (convert_boz (e
, gfc_default_double_kind
) == &gfc_bad_expr
)
2041 return &gfc_bad_expr
;
2043 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
2044 if (result
== &gfc_bad_expr
)
2045 return &gfc_bad_expr
;
2047 return range_check (result
, "DBLE");
2052 gfc_simplify_digits (gfc_expr
*x
)
2056 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2061 digits
= gfc_integer_kinds
[i
].digits
;
2066 digits
= gfc_real_kinds
[i
].digits
;
2073 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
2078 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
2083 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2086 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2087 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
2092 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
2093 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2095 mpz_set_ui (result
->value
.integer
, 0);
2100 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
2101 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
2104 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2109 gfc_internal_error ("gfc_simplify_dim(): Bad type");
2112 return range_check (result
, "DIM");
2117 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2122 if (!is_constant_array_expr (vector_a
)
2123 || !is_constant_array_expr (vector_b
))
2126 gcc_assert (vector_a
->rank
== 1);
2127 gcc_assert (vector_b
->rank
== 1);
2129 temp
.expr_type
= EXPR_OP
;
2130 gfc_clear_ts (&temp
.ts
);
2131 temp
.value
.op
.op
= INTRINSIC_NONE
;
2132 temp
.value
.op
.op1
= vector_a
;
2133 temp
.value
.op
.op2
= vector_b
;
2134 gfc_type_convert_binary (&temp
, 1);
2136 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
2141 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
2143 gfc_expr
*a1
, *a2
, *result
;
2145 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2148 a1
= gfc_real2real (x
, gfc_default_double_kind
);
2149 a2
= gfc_real2real (y
, gfc_default_double_kind
);
2151 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
2152 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
2157 return range_check (result
, "DPROD");
2162 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
2166 int i
, k
, size
, shift
;
2168 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
2169 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
2172 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
2173 size
= gfc_integer_kinds
[k
].bit_size
;
2175 gfc_extract_int (shiftarg
, &shift
);
2177 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2179 shift
= size
- shift
;
2181 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
2182 mpz_set_ui (result
->value
.integer
, 0);
2184 for (i
= 0; i
< shift
; i
++)
2185 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
2186 mpz_setbit (result
->value
.integer
, i
);
2188 for (i
= 0; i
< size
- shift
; i
++)
2189 if (mpz_tstbit (arg1
->value
.integer
, i
))
2190 mpz_setbit (result
->value
.integer
, shift
+ i
);
2192 /* Convert to a signed value. */
2193 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
2200 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2202 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
2207 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2209 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
2214 gfc_simplify_erf (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 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2224 return range_check (result
, "ERF");
2229 gfc_simplify_erfc (gfc_expr
*x
)
2233 if (x
->expr_type
!= EXPR_CONSTANT
)
2236 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2237 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2239 return range_check (result
, "ERFC");
2243 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2245 #define MAX_ITER 200
2246 #define ARG_LIMIT 12
2248 /* Calculate ERFC_SCALED directly by its definition:
2250 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2252 using a large precision for intermediate results. This is used for all
2253 but large values of the argument. */
2255 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2260 prec
= mpfr_get_default_prec ();
2261 mpfr_set_default_prec (10 * prec
);
2266 mpfr_set (a
, arg
, GFC_RND_MODE
);
2267 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2268 mpfr_exp (b
, b
, GFC_RND_MODE
);
2269 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2270 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2272 mpfr_set (res
, a
, GFC_RND_MODE
);
2273 mpfr_set_default_prec (prec
);
2279 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2281 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2282 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2285 This is used for large values of the argument. Intermediate calculations
2286 are performed with twice the precision. We don't do a fixed number of
2287 iterations of the sum, but stop when it has converged to the required
2290 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2292 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2297 prec
= mpfr_get_default_prec ();
2298 mpfr_set_default_prec (2 * prec
);
2308 mpfr_init (sumtrunc
);
2309 mpfr_set_prec (oldsum
, prec
);
2310 mpfr_set_prec (sumtrunc
, prec
);
2312 mpfr_set (x
, arg
, GFC_RND_MODE
);
2313 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2314 mpz_set_ui (num
, 1);
2316 mpfr_set (u
, x
, GFC_RND_MODE
);
2317 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2318 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2319 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2321 for (i
= 1; i
< MAX_ITER
; i
++)
2323 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2325 mpz_mul_ui (num
, num
, 2 * i
- 1);
2328 mpfr_set (w
, u
, GFC_RND_MODE
);
2329 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2331 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2332 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2334 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2336 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2337 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2341 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2343 gcc_assert (i
< MAX_ITER
);
2345 /* Divide by x * sqrt(Pi). */
2346 mpfr_const_pi (u
, GFC_RND_MODE
);
2347 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2348 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2349 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2351 mpfr_set (res
, sum
, GFC_RND_MODE
);
2352 mpfr_set_default_prec (prec
);
2354 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2360 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2364 if (x
->expr_type
!= EXPR_CONSTANT
)
2367 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2368 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2369 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2371 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2373 return range_check (result
, "ERFC_SCALED");
2381 gfc_simplify_epsilon (gfc_expr
*e
)
2386 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2388 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2389 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2391 return range_check (result
, "EPSILON");
2396 gfc_simplify_exp (gfc_expr
*x
)
2400 if (x
->expr_type
!= EXPR_CONSTANT
)
2403 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2408 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2412 gfc_set_model_kind (x
->ts
.kind
);
2413 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2417 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2420 return range_check (result
, "EXP");
2425 gfc_simplify_exponent (gfc_expr
*x
)
2430 if (x
->expr_type
!= EXPR_CONSTANT
)
2433 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2436 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2437 if (mpfr_inf_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
2439 int i
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
2440 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2444 /* EXPONENT(+/- 0.0) = 0 */
2445 if (mpfr_zero_p (x
->value
.real
))
2447 mpz_set_ui (result
->value
.integer
, 0);
2451 gfc_set_model (x
->value
.real
);
2453 val
= (long int) mpfr_get_exp (x
->value
.real
);
2454 mpz_set_si (result
->value
.integer
, val
);
2456 return range_check (result
, "EXPONENT");
2461 gfc_simplify_float (gfc_expr
*a
)
2465 if (a
->expr_type
!= EXPR_CONSTANT
)
2470 if (convert_boz (a
, gfc_default_real_kind
) == &gfc_bad_expr
)
2471 return &gfc_bad_expr
;
2473 result
= gfc_copy_expr (a
);
2476 result
= gfc_int2real (a
, gfc_default_real_kind
);
2478 return range_check (result
, "FLOAT");
2483 is_last_ref_vtab (gfc_expr
*e
)
2486 gfc_component
*comp
= NULL
;
2488 if (e
->expr_type
!= EXPR_VARIABLE
)
2491 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2492 if (ref
->type
== REF_COMPONENT
)
2493 comp
= ref
->u
.c
.component
;
2495 if (!e
->ref
|| !comp
)
2496 return e
->symtree
->n
.sym
->attr
.vtab
;
2498 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
2506 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
2508 /* Avoid simplification of resolved symbols. */
2509 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
2512 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
2513 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2514 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2517 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
2520 /* Return .false. if the dynamic type can never be an extension. */
2521 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
2522 && !gfc_type_is_extension_of
2523 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2524 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
2525 && !gfc_type_is_extension_of
2526 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
2527 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
2528 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
2529 && !gfc_type_is_extension_of
2530 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2532 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
2533 && !gfc_type_is_extension_of
2534 (mold
->ts
.u
.derived
,
2535 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
2536 && !gfc_type_is_extension_of
2537 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
2538 mold
->ts
.u
.derived
)))
2539 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2541 /* Return .true. if the dynamic type is guaranteed to be an extension. */
2542 if (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
2543 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2544 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
2545 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
2552 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
2554 /* Avoid simplification of resolved symbols. */
2555 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
2558 /* Return .false. if the dynamic type can never be the
2560 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
2561 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
2562 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
2563 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
2564 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2566 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
2569 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2570 gfc_compare_derived_types (a
->ts
.u
.derived
,
2576 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
2582 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
2584 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2586 if (e
->expr_type
!= EXPR_CONSTANT
)
2589 mpfr_init2 (floor
, mpfr_get_prec (e
->value
.real
));
2590 mpfr_floor (floor
, e
->value
.real
);
2592 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
2593 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
2597 return range_check (result
, "FLOOR");
2602 gfc_simplify_fraction (gfc_expr
*x
)
2606 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2607 mpfr_t absv
, exp
, pow2
;
2612 if (x
->expr_type
!= EXPR_CONSTANT
)
2615 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
2617 /* FRACTION(inf) = NaN. */
2618 if (mpfr_inf_p (x
->value
.real
))
2620 mpfr_set_nan (result
->value
.real
);
2624 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2626 /* MPFR versions before 3.1.0 do not include mpfr_frexp.
2627 TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
2629 if (mpfr_sgn (x
->value
.real
) == 0)
2631 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2635 gfc_set_model_kind (x
->ts
.kind
);
2640 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
2641 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
2643 mpfr_trunc (exp
, exp
);
2644 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
2646 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
2648 mpfr_div (result
->value
.real
, x
->value
.real
, pow2
, GFC_RND_MODE
);
2650 mpfr_clears (exp
, absv
, pow2
, NULL
);
2654 /* mpfr_frexp() correctly handles zeros and NaNs. */
2655 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2659 return range_check (result
, "FRACTION");
2664 gfc_simplify_gamma (gfc_expr
*x
)
2668 if (x
->expr_type
!= EXPR_CONSTANT
)
2671 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2672 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2674 return range_check (result
, "GAMMA");
2679 gfc_simplify_huge (gfc_expr
*e
)
2684 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2685 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2690 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2694 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
2706 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
2710 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2713 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2714 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
2715 return range_check (result
, "HYPOT");
2719 /* We use the processor's collating sequence, because all
2720 systems that gfortran currently works on are ASCII. */
2723 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
2729 if (e
->expr_type
!= EXPR_CONSTANT
)
2732 if (e
->value
.character
.length
!= 1)
2734 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
2735 return &gfc_bad_expr
;
2738 index
= e
->value
.character
.string
[0];
2740 if (warn_surprising
&& index
> 127)
2741 gfc_warning (OPT_Wsurprising
,
2742 "Argument of IACHAR function at %L outside of range 0..127",
2745 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
2747 return &gfc_bad_expr
;
2749 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2751 return range_check (result
, "IACHAR");
2756 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
2758 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2759 gcc_assert (result
->ts
.type
== BT_INTEGER
2760 && result
->expr_type
== EXPR_CONSTANT
);
2762 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2768 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2770 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
2775 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
2777 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2778 gcc_assert (result
->ts
.type
== BT_INTEGER
2779 && result
->expr_type
== EXPR_CONSTANT
);
2781 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2787 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2789 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
2794 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
2798 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2801 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2802 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2804 return range_check (result
, "IAND");
2809 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
2814 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2817 gfc_extract_int (y
, &pos
);
2819 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2821 result
= gfc_copy_expr (x
);
2823 convert_mpz_to_unsigned (result
->value
.integer
,
2824 gfc_integer_kinds
[k
].bit_size
);
2826 mpz_clrbit (result
->value
.integer
, pos
);
2828 gfc_convert_mpz_to_signed (result
->value
.integer
,
2829 gfc_integer_kinds
[k
].bit_size
);
2836 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
2843 if (x
->expr_type
!= EXPR_CONSTANT
2844 || y
->expr_type
!= EXPR_CONSTANT
2845 || z
->expr_type
!= EXPR_CONSTANT
)
2848 gfc_extract_int (y
, &pos
);
2849 gfc_extract_int (z
, &len
);
2851 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
2853 bitsize
= gfc_integer_kinds
[k
].bit_size
;
2855 if (pos
+ len
> bitsize
)
2857 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2858 "bit size at %L", &y
->where
);
2859 return &gfc_bad_expr
;
2862 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2863 convert_mpz_to_unsigned (result
->value
.integer
,
2864 gfc_integer_kinds
[k
].bit_size
);
2866 bits
= XCNEWVEC (int, bitsize
);
2868 for (i
= 0; i
< bitsize
; i
++)
2871 for (i
= 0; i
< len
; i
++)
2872 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
2874 for (i
= 0; i
< bitsize
; i
++)
2877 mpz_clrbit (result
->value
.integer
, i
);
2878 else if (bits
[i
] == 1)
2879 mpz_setbit (result
->value
.integer
, i
);
2881 gfc_internal_error ("IBITS: Bad bit");
2886 gfc_convert_mpz_to_signed (result
->value
.integer
,
2887 gfc_integer_kinds
[k
].bit_size
);
2894 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
2899 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2902 gfc_extract_int (y
, &pos
);
2904 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2906 result
= gfc_copy_expr (x
);
2908 convert_mpz_to_unsigned (result
->value
.integer
,
2909 gfc_integer_kinds
[k
].bit_size
);
2911 mpz_setbit (result
->value
.integer
, pos
);
2913 gfc_convert_mpz_to_signed (result
->value
.integer
,
2914 gfc_integer_kinds
[k
].bit_size
);
2921 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
2927 if (e
->expr_type
!= EXPR_CONSTANT
)
2930 if (e
->value
.character
.length
!= 1)
2932 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
2933 return &gfc_bad_expr
;
2936 index
= e
->value
.character
.string
[0];
2938 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
2940 return &gfc_bad_expr
;
2942 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2944 return range_check (result
, "ICHAR");
2949 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
2953 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2956 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2957 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2959 return range_check (result
, "IEOR");
2964 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
2967 int back
, len
, lensub
;
2968 int i
, j
, k
, count
, index
= 0, start
;
2970 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
2971 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
2974 if (b
!= NULL
&& b
->value
.logical
!= 0)
2979 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
2981 return &gfc_bad_expr
;
2983 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
2985 len
= x
->value
.character
.length
;
2986 lensub
= y
->value
.character
.length
;
2990 mpz_set_si (result
->value
.integer
, 0);
2998 mpz_set_si (result
->value
.integer
, 1);
3001 else if (lensub
== 1)
3003 for (i
= 0; i
< len
; i
++)
3005 for (j
= 0; j
< lensub
; j
++)
3007 if (y
->value
.character
.string
[j
]
3008 == x
->value
.character
.string
[i
])
3018 for (i
= 0; i
< len
; i
++)
3020 for (j
= 0; j
< lensub
; j
++)
3022 if (y
->value
.character
.string
[j
]
3023 == x
->value
.character
.string
[i
])
3028 for (k
= 0; k
< lensub
; k
++)
3030 if (y
->value
.character
.string
[k
]
3031 == x
->value
.character
.string
[k
+ start
])
3035 if (count
== lensub
)
3050 mpz_set_si (result
->value
.integer
, len
+ 1);
3053 else if (lensub
== 1)
3055 for (i
= 0; i
< len
; i
++)
3057 for (j
= 0; j
< lensub
; j
++)
3059 if (y
->value
.character
.string
[j
]
3060 == x
->value
.character
.string
[len
- i
])
3062 index
= len
- i
+ 1;
3070 for (i
= 0; i
< len
; i
++)
3072 for (j
= 0; j
< lensub
; j
++)
3074 if (y
->value
.character
.string
[j
]
3075 == x
->value
.character
.string
[len
- i
])
3078 if (start
<= len
- lensub
)
3081 for (k
= 0; k
< lensub
; k
++)
3082 if (y
->value
.character
.string
[k
]
3083 == x
->value
.character
.string
[k
+ start
])
3086 if (count
== lensub
)
3103 mpz_set_si (result
->value
.integer
, index
);
3104 return range_check (result
, "INDEX");
3109 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
3111 gfc_expr
*result
= NULL
;
3113 if (e
->expr_type
!= EXPR_CONSTANT
)
3116 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
3117 if (result
== &gfc_bad_expr
)
3118 return &gfc_bad_expr
;
3120 return range_check (result
, name
);
3125 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
3129 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
3131 return &gfc_bad_expr
;
3133 return simplify_intconv (e
, kind
, "INT");
3137 gfc_simplify_int2 (gfc_expr
*e
)
3139 return simplify_intconv (e
, 2, "INT2");
3144 gfc_simplify_int8 (gfc_expr
*e
)
3146 return simplify_intconv (e
, 8, "INT8");
3151 gfc_simplify_long (gfc_expr
*e
)
3153 return simplify_intconv (e
, 4, "LONG");
3158 gfc_simplify_ifix (gfc_expr
*e
)
3160 gfc_expr
*rtrunc
, *result
;
3162 if (e
->expr_type
!= EXPR_CONSTANT
)
3165 rtrunc
= gfc_copy_expr (e
);
3166 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3168 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3170 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3172 gfc_free_expr (rtrunc
);
3174 return range_check (result
, "IFIX");
3179 gfc_simplify_idint (gfc_expr
*e
)
3181 gfc_expr
*rtrunc
, *result
;
3183 if (e
->expr_type
!= EXPR_CONSTANT
)
3186 rtrunc
= gfc_copy_expr (e
);
3187 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3189 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3191 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3193 gfc_free_expr (rtrunc
);
3195 return range_check (result
, "IDINT");
3200 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
3204 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3207 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3208 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3210 return range_check (result
, "IOR");
3215 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
3217 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3218 gcc_assert (result
->ts
.type
== BT_INTEGER
3219 && result
->expr_type
== EXPR_CONSTANT
);
3221 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3227 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3229 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3234 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3236 if (x
->expr_type
!= EXPR_CONSTANT
)
3239 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3240 mpz_cmp_si (x
->value
.integer
,
3241 LIBERROR_END
) == 0);
3246 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3248 if (x
->expr_type
!= EXPR_CONSTANT
)
3251 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3252 mpz_cmp_si (x
->value
.integer
,
3253 LIBERROR_EOR
) == 0);
3258 gfc_simplify_isnan (gfc_expr
*x
)
3260 if (x
->expr_type
!= EXPR_CONSTANT
)
3263 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3264 mpfr_nan_p (x
->value
.real
));
3268 /* Performs a shift on its first argument. Depending on the last
3269 argument, the shift can be arithmetic, i.e. with filling from the
3270 left like in the SHIFTA intrinsic. */
3272 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3273 bool arithmetic
, int direction
)
3276 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3278 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3281 gfc_extract_int (s
, &shift
);
3283 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3284 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3286 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3290 mpz_set (result
->value
.integer
, e
->value
.integer
);
3294 if (direction
> 0 && shift
< 0)
3296 /* Left shift, as in SHIFTL. */
3297 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3298 return &gfc_bad_expr
;
3300 else if (direction
< 0)
3302 /* Right shift, as in SHIFTR or SHIFTA. */
3305 gfc_error ("Second argument of %s is negative at %L",
3307 return &gfc_bad_expr
;
3313 ashift
= (shift
>= 0 ? shift
: -shift
);
3315 if (ashift
> bitsize
)
3317 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3318 "at %L", name
, &e
->where
);
3319 return &gfc_bad_expr
;
3322 bits
= XCNEWVEC (int, bitsize
);
3324 for (i
= 0; i
< bitsize
; i
++)
3325 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3330 for (i
= 0; i
< shift
; i
++)
3331 mpz_clrbit (result
->value
.integer
, i
);
3333 for (i
= 0; i
< bitsize
- shift
; i
++)
3336 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3338 mpz_setbit (result
->value
.integer
, i
+ shift
);
3344 if (arithmetic
&& bits
[bitsize
- 1])
3345 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3346 mpz_setbit (result
->value
.integer
, i
);
3348 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3349 mpz_clrbit (result
->value
.integer
, i
);
3351 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3354 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3356 mpz_setbit (result
->value
.integer
, i
- ashift
);
3360 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3368 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3370 return simplify_shift (e
, s
, "ISHFT", false, 0);
3375 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3377 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3382 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3384 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3389 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3391 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3396 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3398 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3403 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3405 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3410 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3413 int shift
, ashift
, isize
, ssize
, delta
, k
;
3416 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3419 gfc_extract_int (s
, &shift
);
3421 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3422 isize
= gfc_integer_kinds
[k
].bit_size
;
3426 if (sz
->expr_type
!= EXPR_CONSTANT
)
3429 gfc_extract_int (sz
, &ssize
);
3442 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3443 "BIT_SIZE of first argument at %C");
3445 gfc_error ("Absolute value of SHIFT shall be less than or equal "
3447 return &gfc_bad_expr
;
3450 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3452 mpz_set (result
->value
.integer
, e
->value
.integer
);
3457 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
3459 bits
= XCNEWVEC (int, ssize
);
3461 for (i
= 0; i
< ssize
; i
++)
3462 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3464 delta
= ssize
- ashift
;
3468 for (i
= 0; i
< delta
; i
++)
3471 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3473 mpz_setbit (result
->value
.integer
, i
+ shift
);
3476 for (i
= delta
; i
< ssize
; i
++)
3479 mpz_clrbit (result
->value
.integer
, i
- delta
);
3481 mpz_setbit (result
->value
.integer
, i
- delta
);
3486 for (i
= 0; i
< ashift
; i
++)
3489 mpz_clrbit (result
->value
.integer
, i
+ delta
);
3491 mpz_setbit (result
->value
.integer
, i
+ delta
);
3494 for (i
= ashift
; i
< ssize
; i
++)
3497 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3499 mpz_setbit (result
->value
.integer
, i
+ shift
);
3503 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
3511 gfc_simplify_kind (gfc_expr
*e
)
3513 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
3518 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
3519 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
3521 gfc_expr
*l
, *u
, *result
;
3524 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3525 gfc_default_integer_kind
);
3527 return &gfc_bad_expr
;
3529 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3531 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3532 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3533 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
3537 gfc_expr
* dim
= result
;
3538 mpz_set_si (dim
->value
.integer
, d
);
3540 result
= simplify_size (array
, dim
, k
);
3541 gfc_free_expr (dim
);
3546 mpz_set_si (result
->value
.integer
, 1);
3551 /* Otherwise, we have a variable expression. */
3552 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
3555 if (!gfc_resolve_array_spec (as
, 0))
3558 /* The last dimension of an assumed-size array is special. */
3559 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
3560 || (coarray
&& d
== as
->rank
+ as
->corank
3561 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
3563 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
3565 gfc_free_expr (result
);
3566 return gfc_copy_expr (as
->lower
[d
-1]);
3572 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3574 /* Then, we need to know the extent of the given dimension. */
3575 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
3577 gfc_expr
*declared_bound
;
3579 bool constant_lbound
, constant_ubound
;
3584 gcc_assert (l
!= NULL
);
3586 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
3587 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
3589 empty_bound
= upper
? 0 : 1;
3590 declared_bound
= upper
? u
: l
;
3592 if ((!upper
&& !constant_lbound
)
3593 || (upper
&& !constant_ubound
))
3598 /* For {L,U}BOUND, the value depends on whether the array
3599 is empty. We can nevertheless simplify if the declared bound
3600 has the same value as that of an empty array, in which case
3601 the result isn't dependent on the array emptyness. */
3602 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
3603 mpz_set_si (result
->value
.integer
, empty_bound
);
3604 else if (!constant_lbound
|| !constant_ubound
)
3605 /* Array emptyness can't be determined, we can't simplify. */
3607 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
3608 mpz_set_si (result
->value
.integer
, empty_bound
);
3610 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
3613 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
3619 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d
- 1, &result
->value
.integer
, NULL
))
3623 mpz_set_si (result
->value
.integer
, (long int) 1);
3627 return range_check (result
, upper
? "UBOUND" : "LBOUND");
3630 gfc_free_expr (result
);
3636 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3642 if (array
->ts
.type
== BT_CLASS
)
3645 if (array
->expr_type
!= EXPR_VARIABLE
)
3652 /* Follow any component references. */
3653 as
= array
->symtree
->n
.sym
->as
;
3654 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3659 switch (ref
->u
.ar
.type
)
3666 /* We're done because 'as' has already been set in the
3667 previous iteration. */
3681 as
= ref
->u
.c
.component
->as
;
3693 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
3694 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
3698 || (as
->type
!= AS_DEFERRED
3699 && array
->expr_type
== EXPR_VARIABLE
3700 && !gfc_expr_attr (array
).allocatable
3701 && !gfc_expr_attr (array
).pointer
));
3705 /* Multi-dimensional bounds. */
3706 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3710 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
3711 if (upper
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
3713 /* An error message will be emitted in
3714 check_assumed_size_reference (resolve.c). */
3715 return &gfc_bad_expr
;
3718 /* Simplify the bounds for each dimension. */
3719 for (d
= 0; d
< array
->rank
; d
++)
3721 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
3723 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3727 for (j
= 0; j
< d
; j
++)
3728 gfc_free_expr (bounds
[j
]);
3733 /* Allocate the result expression. */
3734 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3735 gfc_default_integer_kind
);
3737 return &gfc_bad_expr
;
3739 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
3741 /* The result is a rank 1 array; its size is the rank of the first
3742 argument to {L,U}BOUND. */
3744 e
->shape
= gfc_get_shape (1);
3745 mpz_init_set_ui (e
->shape
[0], array
->rank
);
3747 /* Create the constructor for this array. */
3748 for (d
= 0; d
< array
->rank
; d
++)
3749 gfc_constructor_append_expr (&e
->value
.constructor
,
3750 bounds
[d
], &e
->where
);
3756 /* A DIM argument is specified. */
3757 if (dim
->expr_type
!= EXPR_CONSTANT
)
3760 d
= mpz_get_si (dim
->value
.integer
);
3762 if ((d
< 1 || d
> array
->rank
)
3763 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
3765 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3766 return &gfc_bad_expr
;
3769 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3772 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
3778 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3784 if (array
->expr_type
!= EXPR_VARIABLE
)
3787 /* Follow any component references. */
3788 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
3789 ? array
->ts
.u
.derived
->components
->as
3790 : array
->symtree
->n
.sym
->as
;
3791 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3796 switch (ref
->u
.ar
.type
)
3799 if (ref
->u
.ar
.as
->corank
> 0)
3801 gcc_assert (as
== ref
->u
.ar
.as
);
3808 /* We're done because 'as' has already been set in the
3809 previous iteration. */
3823 as
= ref
->u
.c
.component
->as
;
3836 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
3841 /* Multi-dimensional cobounds. */
3842 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3846 /* Simplify the cobounds for each dimension. */
3847 for (d
= 0; d
< as
->corank
; d
++)
3849 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
3850 upper
, as
, ref
, true);
3851 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3855 for (j
= 0; j
< d
; j
++)
3856 gfc_free_expr (bounds
[j
]);
3861 /* Allocate the result expression. */
3862 e
= gfc_get_expr ();
3863 e
->where
= array
->where
;
3864 e
->expr_type
= EXPR_ARRAY
;
3865 e
->ts
.type
= BT_INTEGER
;
3866 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
3867 gfc_default_integer_kind
);
3871 return &gfc_bad_expr
;
3875 /* The result is a rank 1 array; its size is the rank of the first
3876 argument to {L,U}COBOUND. */
3878 e
->shape
= gfc_get_shape (1);
3879 mpz_init_set_ui (e
->shape
[0], as
->corank
);
3881 /* Create the constructor for this array. */
3882 for (d
= 0; d
< as
->corank
; d
++)
3883 gfc_constructor_append_expr (&e
->value
.constructor
,
3884 bounds
[d
], &e
->where
);
3889 /* A DIM argument is specified. */
3890 if (dim
->expr_type
!= EXPR_CONSTANT
)
3893 d
= mpz_get_si (dim
->value
.integer
);
3895 if (d
< 1 || d
> as
->corank
)
3897 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3898 return &gfc_bad_expr
;
3901 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
3907 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3909 return simplify_bound (array
, dim
, kind
, 0);
3914 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3916 return simplify_cobound (array
, dim
, kind
, 0);
3920 gfc_simplify_leadz (gfc_expr
*e
)
3922 unsigned long lz
, bs
;
3925 if (e
->expr_type
!= EXPR_CONSTANT
)
3928 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3929 bs
= gfc_integer_kinds
[i
].bit_size
;
3930 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
3932 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
3935 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
3937 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
3942 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
3945 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
3948 return &gfc_bad_expr
;
3950 if (e
->expr_type
== EXPR_CONSTANT
)
3952 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3953 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
3954 return range_check (result
, "LEN");
3956 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
3957 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3958 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
3960 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3961 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
3962 return range_check (result
, "LEN");
3964 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
3965 && e
->symtree
->n
.sym
3966 && e
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
3967 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
3968 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
3969 && e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
3970 && UNLIMITED_POLY (e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
))
3972 /* The expression in assoc->target points to a ref to the _data component
3973 of the unlimited polymorphic entity. To get the _len component the last
3974 _data ref needs to be stripped and a ref to the _len component added. */
3975 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
);
3982 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
3986 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
3989 return &gfc_bad_expr
;
3991 if (e
->expr_type
!= EXPR_CONSTANT
)
3994 len
= e
->value
.character
.length
;
3995 for (count
= 0, i
= 1; i
<= len
; i
++)
3996 if (e
->value
.character
.string
[len
- i
] == ' ')
4001 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
4002 return range_check (result
, "LEN_TRIM");
4006 gfc_simplify_lgamma (gfc_expr
*x
)
4011 if (x
->expr_type
!= EXPR_CONSTANT
)
4014 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4015 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
4017 return range_check (result
, "LGAMMA");
4022 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
4024 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4027 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4028 gfc_compare_string (a
, b
) >= 0);
4033 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
4035 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4038 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4039 gfc_compare_string (a
, b
) > 0);
4044 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
4046 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4049 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4050 gfc_compare_string (a
, b
) <= 0);
4055 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
4057 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4060 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4061 gfc_compare_string (a
, b
) < 0);
4066 gfc_simplify_log (gfc_expr
*x
)
4070 if (x
->expr_type
!= EXPR_CONSTANT
)
4073 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4078 if (mpfr_sgn (x
->value
.real
) <= 0)
4080 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4081 "to zero", &x
->where
);
4082 gfc_free_expr (result
);
4083 return &gfc_bad_expr
;
4086 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4090 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
4091 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
4093 gfc_error ("Complex argument of LOG at %L cannot be zero",
4095 gfc_free_expr (result
);
4096 return &gfc_bad_expr
;
4099 gfc_set_model_kind (x
->ts
.kind
);
4100 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
4104 gfc_internal_error ("gfc_simplify_log: bad type");
4107 return range_check (result
, "LOG");
4112 gfc_simplify_log10 (gfc_expr
*x
)
4116 if (x
->expr_type
!= EXPR_CONSTANT
)
4119 if (mpfr_sgn (x
->value
.real
) <= 0)
4121 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4122 "to zero", &x
->where
);
4123 return &gfc_bad_expr
;
4126 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4127 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4129 return range_check (result
, "LOG10");
4134 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
4138 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
4140 return &gfc_bad_expr
;
4142 if (e
->expr_type
!= EXPR_CONSTANT
)
4145 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
4150 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
4153 int row
, result_rows
, col
, result_columns
;
4154 int stride_a
, offset_a
, stride_b
, offset_b
;
4156 if (!is_constant_array_expr (matrix_a
)
4157 || !is_constant_array_expr (matrix_b
))
4160 gcc_assert (gfc_compare_types (&matrix_a
->ts
, &matrix_b
->ts
));
4161 result
= gfc_get_array_expr (matrix_a
->ts
.type
,
4165 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
4168 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4170 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4173 result
->shape
= gfc_get_shape (result
->rank
);
4174 mpz_init_set_si (result
->shape
[0], result_columns
);
4176 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
4178 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4180 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4184 result
->shape
= gfc_get_shape (result
->rank
);
4185 mpz_init_set_si (result
->shape
[0], result_rows
);
4187 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
4189 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4190 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4191 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4192 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4195 result
->shape
= gfc_get_shape (result
->rank
);
4196 mpz_init_set_si (result
->shape
[0], result_rows
);
4197 mpz_init_set_si (result
->shape
[1], result_columns
);
4202 offset_a
= offset_b
= 0;
4203 for (col
= 0; col
< result_columns
; ++col
)
4207 for (row
= 0; row
< result_rows
; ++row
)
4209 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
4210 matrix_b
, 1, offset_b
, false);
4211 gfc_constructor_append_expr (&result
->value
.constructor
,
4217 offset_b
+= stride_b
;
4225 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
4231 if (i
->expr_type
!= EXPR_CONSTANT
)
4234 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
4236 return &gfc_bad_expr
;
4237 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4239 s
= gfc_extract_int (i
, &arg
);
4242 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4244 /* MASKR(n) = 2^n - 1 */
4245 mpz_set_ui (result
->value
.integer
, 1);
4246 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4247 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4249 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4256 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4263 if (i
->expr_type
!= EXPR_CONSTANT
)
4266 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4268 return &gfc_bad_expr
;
4269 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4271 s
= gfc_extract_int (i
, &arg
);
4274 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4276 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4277 mpz_init_set_ui (z
, 1);
4278 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4279 mpz_set_ui (result
->value
.integer
, 1);
4280 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4281 gfc_integer_kinds
[k
].bit_size
- arg
);
4282 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4285 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4292 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4295 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4297 if (mask
->expr_type
== EXPR_CONSTANT
)
4298 return gfc_get_parentheses (gfc_copy_expr (mask
->value
.logical
4299 ? tsource
: fsource
));
4301 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4302 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4305 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4307 if (tsource
->ts
.type
== BT_DERIVED
)
4308 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4309 else if (tsource
->ts
.type
== BT_CHARACTER
)
4310 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4312 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4313 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4314 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4318 if (mask_ctor
->expr
->value
.logical
)
4319 gfc_constructor_append_expr (&result
->value
.constructor
,
4320 gfc_copy_expr (tsource_ctor
->expr
),
4323 gfc_constructor_append_expr (&result
->value
.constructor
,
4324 gfc_copy_expr (fsource_ctor
->expr
),
4326 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4327 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4328 mask_ctor
= gfc_constructor_next (mask_ctor
);
4331 result
->shape
= gfc_get_shape (1);
4332 gfc_array_size (result
, &result
->shape
[0]);
4339 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4341 mpz_t arg1
, arg2
, mask
;
4344 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4345 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4348 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4350 /* Convert all argument to unsigned. */
4351 mpz_init_set (arg1
, i
->value
.integer
);
4352 mpz_init_set (arg2
, j
->value
.integer
);
4353 mpz_init_set (mask
, mask_expr
->value
.integer
);
4355 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4356 mpz_and (arg1
, arg1
, mask
);
4357 mpz_com (mask
, mask
);
4358 mpz_and (arg2
, arg2
, mask
);
4359 mpz_ior (result
->value
.integer
, arg1
, arg2
);
4369 /* Selects between current value and extremum for simplify_min_max
4370 and simplify_minval_maxval. */
4372 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
)
4374 switch (arg
->ts
.type
)
4377 if (mpz_cmp (arg
->value
.integer
,
4378 extremum
->value
.integer
) * sign
> 0)
4379 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
4383 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4385 mpfr_max (extremum
->value
.real
, extremum
->value
.real
,
4386 arg
->value
.real
, GFC_RND_MODE
);
4388 mpfr_min (extremum
->value
.real
, extremum
->value
.real
,
4389 arg
->value
.real
, GFC_RND_MODE
);
4393 #define LENGTH(x) ((x)->value.character.length)
4394 #define STRING(x) ((x)->value.character.string)
4395 if (LENGTH (extremum
) < LENGTH(arg
))
4397 gfc_char_t
*tmp
= STRING(extremum
);
4399 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
4400 memcpy (STRING(extremum
), tmp
,
4401 LENGTH(extremum
) * sizeof (gfc_char_t
));
4402 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
4403 LENGTH(arg
) - LENGTH(extremum
));
4404 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
4405 LENGTH(extremum
) = LENGTH(arg
);
4409 if (gfc_compare_string (arg
, extremum
) * sign
> 0)
4411 free (STRING(extremum
));
4412 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
4413 memcpy (STRING(extremum
), STRING(arg
),
4414 LENGTH(arg
) * sizeof (gfc_char_t
));
4415 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
4416 LENGTH(extremum
) - LENGTH(arg
));
4417 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
4424 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4429 /* This function is special since MAX() can take any number of
4430 arguments. The simplified expression is a rewritten version of the
4431 argument list containing at most one constant element. Other
4432 constant elements are deleted. Because the argument list has
4433 already been checked, this function always succeeds. sign is 1 for
4434 MAX(), -1 for MIN(). */
4437 simplify_min_max (gfc_expr
*expr
, int sign
)
4439 gfc_actual_arglist
*arg
, *last
, *extremum
;
4440 gfc_intrinsic_sym
* specific
;
4444 specific
= expr
->value
.function
.isym
;
4446 arg
= expr
->value
.function
.actual
;
4448 for (; arg
; last
= arg
, arg
= arg
->next
)
4450 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
4453 if (extremum
== NULL
)
4459 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
4461 /* Delete the extra constant argument. */
4462 last
->next
= arg
->next
;
4465 gfc_free_actual_arglist (arg
);
4469 /* If there is one value left, replace the function call with the
4471 if (expr
->value
.function
.actual
->next
!= NULL
)
4474 /* Convert to the correct type and kind. */
4475 if (expr
->ts
.type
!= BT_UNKNOWN
)
4476 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4477 expr
->ts
.type
, expr
->ts
.kind
);
4479 if (specific
->ts
.type
!= BT_UNKNOWN
)
4480 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4481 specific
->ts
.type
, specific
->ts
.kind
);
4483 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
4488 gfc_simplify_min (gfc_expr
*e
)
4490 return simplify_min_max (e
, -1);
4495 gfc_simplify_max (gfc_expr
*e
)
4497 return simplify_min_max (e
, 1);
4501 /* This is a simplified version of simplify_min_max to provide
4502 simplification of minval and maxval for a vector. */
4505 simplify_minval_maxval (gfc_expr
*expr
, int sign
)
4507 gfc_constructor
*c
, *extremum
;
4508 gfc_intrinsic_sym
* specific
;
4511 specific
= expr
->value
.function
.isym
;
4513 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4514 c
; c
= gfc_constructor_next (c
))
4516 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4519 if (extremum
== NULL
)
4525 min_max_choose (c
->expr
, extremum
->expr
, sign
);
4528 if (extremum
== NULL
)
4531 /* Convert to the correct type and kind. */
4532 if (expr
->ts
.type
!= BT_UNKNOWN
)
4533 return gfc_convert_constant (extremum
->expr
,
4534 expr
->ts
.type
, expr
->ts
.kind
);
4536 if (specific
->ts
.type
!= BT_UNKNOWN
)
4537 return gfc_convert_constant (extremum
->expr
,
4538 specific
->ts
.type
, specific
->ts
.kind
);
4540 return gfc_copy_expr (extremum
->expr
);
4545 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4547 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4550 return simplify_minval_maxval (array
, -1);
4555 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4557 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4560 return simplify_minval_maxval (array
, 1);
4565 gfc_simplify_maxexponent (gfc_expr
*x
)
4567 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4568 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4569 gfc_real_kinds
[i
].max_exponent
);
4574 gfc_simplify_minexponent (gfc_expr
*x
)
4576 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4577 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4578 gfc_real_kinds
[i
].min_exponent
);
4583 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
4588 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4591 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4592 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4597 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4599 /* Result is processor-dependent. */
4600 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
4601 gfc_free_expr (result
);
4602 return &gfc_bad_expr
;
4604 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4608 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4610 /* Result is processor-dependent. */
4611 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
4612 gfc_free_expr (result
);
4613 return &gfc_bad_expr
;
4616 gfc_set_model_kind (kind
);
4617 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4622 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4625 return range_check (result
, "MOD");
4630 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
4635 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4638 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4639 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4644 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4646 /* Result is processor-dependent. This processor just opts
4647 to not handle it at all. */
4648 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
4649 gfc_free_expr (result
);
4650 return &gfc_bad_expr
;
4652 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4657 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4659 /* Result is processor-dependent. */
4660 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
4661 gfc_free_expr (result
);
4662 return &gfc_bad_expr
;
4665 gfc_set_model_kind (kind
);
4666 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4668 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
4670 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
4671 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
4675 mpfr_copysign (result
->value
.real
, result
->value
.real
,
4676 p
->value
.real
, GFC_RND_MODE
);
4680 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4683 return range_check (result
, "MODULO");
4688 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
4691 mp_exp_t emin
, emax
;
4694 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
4697 result
= gfc_copy_expr (x
);
4699 /* Save current values of emin and emax. */
4700 emin
= mpfr_get_emin ();
4701 emax
= mpfr_get_emax ();
4703 /* Set emin and emax for the current model number. */
4704 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
4705 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
4706 mpfr_get_prec(result
->value
.real
) + 1);
4707 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
4708 mpfr_check_range (result
->value
.real
, 0, GMP_RNDU
);
4710 if (mpfr_sgn (s
->value
.real
) > 0)
4712 mpfr_nextabove (result
->value
.real
);
4713 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
4717 mpfr_nextbelow (result
->value
.real
);
4718 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
4721 mpfr_set_emin (emin
);
4722 mpfr_set_emax (emax
);
4724 /* Only NaN can occur. Do not use range check as it gives an
4725 error for denormal numbers. */
4726 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
4728 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
4729 gfc_free_expr (result
);
4730 return &gfc_bad_expr
;
4738 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
4740 gfc_expr
*itrunc
, *result
;
4743 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
4745 return &gfc_bad_expr
;
4747 if (e
->expr_type
!= EXPR_CONSTANT
)
4750 itrunc
= gfc_copy_expr (e
);
4751 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
4753 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
4754 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
4756 gfc_free_expr (itrunc
);
4758 return range_check (result
, name
);
4763 gfc_simplify_new_line (gfc_expr
*e
)
4767 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
4768 result
->value
.character
.string
[0] = '\n';
4775 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
4777 return simplify_nint ("NINT", e
, k
);
4782 gfc_simplify_idnint (gfc_expr
*e
)
4784 return simplify_nint ("IDNINT", e
, NULL
);
4789 add_squared (gfc_expr
*result
, gfc_expr
*e
)
4793 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4794 gcc_assert (result
->ts
.type
== BT_REAL
4795 && result
->expr_type
== EXPR_CONSTANT
);
4797 gfc_set_model_kind (result
->ts
.kind
);
4799 mpfr_pow_ui (tmp
, e
->value
.real
, 2, GFC_RND_MODE
);
4800 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
4809 do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
4811 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4812 gcc_assert (result
->ts
.type
== BT_REAL
4813 && result
->expr_type
== EXPR_CONSTANT
);
4815 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
4816 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4822 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
4826 if (!is_constant_array_expr (e
)
4827 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
4830 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4831 init_result_expr (result
, 0, NULL
);
4833 if (!dim
|| e
->rank
== 1)
4835 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
4837 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4840 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
4841 add_squared
, &do_sqrt
);
4848 gfc_simplify_not (gfc_expr
*e
)
4852 if (e
->expr_type
!= EXPR_CONSTANT
)
4855 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4856 mpz_com (result
->value
.integer
, e
->value
.integer
);
4858 return range_check (result
, "NOT");
4863 gfc_simplify_null (gfc_expr
*mold
)
4869 result
= gfc_copy_expr (mold
);
4870 result
->expr_type
= EXPR_NULL
;
4873 result
= gfc_get_null_expr (NULL
);
4880 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
4884 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4886 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4887 return &gfc_bad_expr
;
4890 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
4893 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
4896 /* FIXME: gfc_current_locus is wrong. */
4897 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
4898 &gfc_current_locus
);
4900 if (failed
&& failed
->value
.logical
!= 0)
4901 mpz_set_si (result
->value
.integer
, 0);
4903 mpz_set_si (result
->value
.integer
, 1);
4910 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
4915 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4918 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4923 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
4924 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4925 return range_check (result
, "OR");
4928 return gfc_get_logical_expr (kind
, &x
->where
,
4929 x
->value
.logical
|| y
->value
.logical
);
4937 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4940 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
4942 if (!is_constant_array_expr (array
)
4943 || !is_constant_array_expr (vector
)
4944 || (!gfc_is_constant_expr (mask
)
4945 && !is_constant_array_expr (mask
)))
4948 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
4949 if (array
->ts
.type
== BT_DERIVED
)
4950 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
4952 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
4953 vector_ctor
= vector
4954 ? gfc_constructor_first (vector
->value
.constructor
)
4957 if (mask
->expr_type
== EXPR_CONSTANT
4958 && mask
->value
.logical
)
4960 /* Copy all elements of ARRAY to RESULT. */
4963 gfc_constructor_append_expr (&result
->value
.constructor
,
4964 gfc_copy_expr (array_ctor
->expr
),
4967 array_ctor
= gfc_constructor_next (array_ctor
);
4968 vector_ctor
= gfc_constructor_next (vector_ctor
);
4971 else if (mask
->expr_type
== EXPR_ARRAY
)
4973 /* Copy only those elements of ARRAY to RESULT whose
4974 MASK equals .TRUE.. */
4975 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4978 if (mask_ctor
->expr
->value
.logical
)
4980 gfc_constructor_append_expr (&result
->value
.constructor
,
4981 gfc_copy_expr (array_ctor
->expr
),
4983 vector_ctor
= gfc_constructor_next (vector_ctor
);
4986 array_ctor
= gfc_constructor_next (array_ctor
);
4987 mask_ctor
= gfc_constructor_next (mask_ctor
);
4991 /* Append any left-over elements from VECTOR to RESULT. */
4994 gfc_constructor_append_expr (&result
->value
.constructor
,
4995 gfc_copy_expr (vector_ctor
->expr
),
4997 vector_ctor
= gfc_constructor_next (vector_ctor
);
5000 result
->shape
= gfc_get_shape (1);
5001 gfc_array_size (result
, &result
->shape
[0]);
5003 if (array
->ts
.type
== BT_CHARACTER
)
5004 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
5011 do_xor (gfc_expr
*result
, gfc_expr
*e
)
5013 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
5014 gcc_assert (result
->ts
.type
== BT_LOGICAL
5015 && result
->expr_type
== EXPR_CONSTANT
);
5017 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
5024 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
5026 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
5031 gfc_simplify_popcnt (gfc_expr
*e
)
5036 if (e
->expr_type
!= EXPR_CONSTANT
)
5039 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5041 /* Convert argument to unsigned, then count the '1' bits. */
5042 mpz_init_set (x
, e
->value
.integer
);
5043 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
5044 res
= mpz_popcount (x
);
5047 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
5052 gfc_simplify_poppar (gfc_expr
*e
)
5058 if (e
->expr_type
!= EXPR_CONSTANT
)
5061 popcnt
= gfc_simplify_popcnt (e
);
5062 gcc_assert (popcnt
);
5064 s
= gfc_extract_int (popcnt
, &i
);
5067 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
5072 gfc_simplify_precision (gfc_expr
*e
)
5074 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5075 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
5076 gfc_real_kinds
[i
].precision
);
5081 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
5083 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
5088 gfc_simplify_radix (gfc_expr
*e
)
5091 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5096 i
= gfc_integer_kinds
[i
].radix
;
5100 i
= gfc_real_kinds
[i
].radix
;
5107 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
5112 gfc_simplify_range (gfc_expr
*e
)
5115 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5120 i
= gfc_integer_kinds
[i
].range
;
5125 i
= gfc_real_kinds
[i
].range
;
5132 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
5137 gfc_simplify_rank (gfc_expr
*e
)
5143 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
5148 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
5150 gfc_expr
*result
= NULL
;
5153 if (e
->ts
.type
== BT_COMPLEX
)
5154 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
5156 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
5159 return &gfc_bad_expr
;
5161 if (e
->expr_type
!= EXPR_CONSTANT
)
5164 if (convert_boz (e
, kind
) == &gfc_bad_expr
)
5165 return &gfc_bad_expr
;
5167 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
5168 if (result
== &gfc_bad_expr
)
5169 return &gfc_bad_expr
;
5171 return range_check (result
, "REAL");
5176 gfc_simplify_realpart (gfc_expr
*e
)
5180 if (e
->expr_type
!= EXPR_CONSTANT
)
5183 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
5184 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
5186 return range_check (result
, "REALPART");
5190 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
5193 int i
, j
, len
, ncop
, nlen
;
5195 bool have_length
= false;
5197 /* If NCOPIES isn't a constant, there's nothing we can do. */
5198 if (n
->expr_type
!= EXPR_CONSTANT
)
5201 /* If NCOPIES is negative, it's an error. */
5202 if (mpz_sgn (n
->value
.integer
) < 0)
5204 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
5206 return &gfc_bad_expr
;
5209 /* If we don't know the character length, we can do no more. */
5210 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
5211 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5213 len
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
5216 else if (e
->expr_type
== EXPR_CONSTANT
5217 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
5219 len
= e
->value
.character
.length
;
5224 /* If the source length is 0, any value of NCOPIES is valid
5225 and everything behaves as if NCOPIES == 0. */
5228 mpz_set_ui (ncopies
, 0);
5230 mpz_set (ncopies
, n
->value
.integer
);
5232 /* Check that NCOPIES isn't too large. */
5238 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
5240 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5244 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
5245 e
->ts
.u
.cl
->length
->value
.integer
);
5249 mpz_init_set_si (mlen
, len
);
5250 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
5254 /* The check itself. */
5255 if (mpz_cmp (ncopies
, max
) > 0)
5258 mpz_clear (ncopies
);
5259 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
5261 return &gfc_bad_expr
;
5266 mpz_clear (ncopies
);
5268 /* For further simplification, we need the character string to be
5270 if (e
->expr_type
!= EXPR_CONSTANT
)
5274 (e
->ts
.u
.cl
->length
&&
5275 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
) != 0))
5277 const char *res
= gfc_extract_int (n
, &ncop
);
5278 gcc_assert (res
== NULL
);
5284 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
5286 len
= e
->value
.character
.length
;
5289 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
5290 for (i
= 0; i
< ncop
; i
++)
5291 for (j
= 0; j
< len
; j
++)
5292 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
5294 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
5299 /* This one is a bear, but mainly has to do with shuffling elements. */
5302 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
5303 gfc_expr
*pad
, gfc_expr
*order_exp
)
5305 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
5306 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
5310 gfc_expr
*e
, *result
;
5312 /* Check that argument expression types are OK. */
5313 if (!is_constant_array_expr (source
)
5314 || !is_constant_array_expr (shape_exp
)
5315 || !is_constant_array_expr (pad
)
5316 || !is_constant_array_expr (order_exp
))
5319 if (source
->shape
== NULL
)
5322 /* Proceed with simplification, unpacking the array. */
5329 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
5333 gfc_extract_int (e
, &shape
[rank
]);
5335 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
5336 gcc_assert (shape
[rank
] >= 0);
5341 gcc_assert (rank
> 0);
5343 /* Now unpack the order array if present. */
5344 if (order_exp
== NULL
)
5346 for (i
= 0; i
< rank
; i
++)
5351 for (i
= 0; i
< rank
; i
++)
5354 for (i
= 0; i
< rank
; i
++)
5356 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
5359 gfc_extract_int (e
, &order
[i
]);
5361 gcc_assert (order
[i
] >= 1 && order
[i
] <= rank
);
5363 gcc_assert (x
[order
[i
]] == 0);
5368 /* Count the elements in the source and padding arrays. */
5373 gfc_array_size (pad
, &size
);
5374 npad
= mpz_get_ui (size
);
5378 gfc_array_size (source
, &size
);
5379 nsource
= mpz_get_ui (size
);
5382 /* If it weren't for that pesky permutation we could just loop
5383 through the source and round out any shortage with pad elements.
5384 But no, someone just had to have the compiler do something the
5385 user should be doing. */
5387 for (i
= 0; i
< rank
; i
++)
5390 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
5392 if (source
->ts
.type
== BT_DERIVED
)
5393 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
5394 result
->rank
= rank
;
5395 result
->shape
= gfc_get_shape (rank
);
5396 for (i
= 0; i
< rank
; i
++)
5397 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
5399 while (nsource
> 0 || npad
> 0)
5401 /* Figure out which element to extract. */
5402 mpz_set_ui (index
, 0);
5404 for (i
= rank
- 1; i
>= 0; i
--)
5406 mpz_add_ui (index
, index
, x
[order
[i
]]);
5408 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
5411 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
5412 gfc_internal_error ("Reshaped array too large at %C");
5414 j
= mpz_get_ui (index
);
5417 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
5427 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
5431 gfc_constructor_append_expr (&result
->value
.constructor
,
5432 gfc_copy_expr (e
), &e
->where
);
5434 /* Calculate the next element. */
5438 if (++x
[i
] < shape
[i
])
5454 gfc_simplify_rrspacing (gfc_expr
*x
)
5460 if (x
->expr_type
!= EXPR_CONSTANT
)
5463 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5465 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5467 /* RRSPACING(+/- 0.0) = 0.0 */
5468 if (mpfr_zero_p (x
->value
.real
))
5470 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5474 /* RRSPACING(inf) = NaN */
5475 if (mpfr_inf_p (x
->value
.real
))
5477 mpfr_set_nan (result
->value
.real
);
5481 /* RRSPACING(NaN) = same NaN */
5482 if (mpfr_nan_p (x
->value
.real
))
5484 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5488 /* | x * 2**(-e) | * 2**p. */
5489 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5490 e
= - (long int) mpfr_get_exp (x
->value
.real
);
5491 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
5493 p
= (long int) gfc_real_kinds
[i
].digits
;
5494 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
5496 return range_check (result
, "RRSPACING");
5501 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
5503 int k
, neg_flag
, power
, exp_range
;
5504 mpfr_t scale
, radix
;
5507 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5510 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5512 if (mpfr_zero_p (x
->value
.real
))
5514 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5518 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5520 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
5522 /* This check filters out values of i that would overflow an int. */
5523 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
5524 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
5526 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
5527 gfc_free_expr (result
);
5528 return &gfc_bad_expr
;
5531 /* Compute scale = radix ** power. */
5532 power
= mpz_get_si (i
->value
.integer
);
5542 gfc_set_model_kind (x
->ts
.kind
);
5545 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
5546 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
5549 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5551 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5553 mpfr_clears (scale
, radix
, NULL
);
5555 return range_check (result
, "SCALE");
5559 /* Variants of strspn and strcspn that operate on wide characters. */
5562 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5565 const gfc_char_t
*c
;
5569 for (c
= s2
; *c
; c
++)
5583 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5586 const gfc_char_t
*c
;
5590 for (c
= s2
; *c
; c
++)
5605 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
5610 size_t indx
, len
, lenc
;
5611 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
5614 return &gfc_bad_expr
;
5616 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
5617 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
5620 if (b
!= NULL
&& b
->value
.logical
!= 0)
5625 len
= e
->value
.character
.length
;
5626 lenc
= c
->value
.character
.length
;
5628 if (len
== 0 || lenc
== 0)
5636 indx
= wide_strcspn (e
->value
.character
.string
,
5637 c
->value
.character
.string
) + 1;
5644 for (indx
= len
; indx
> 0; indx
--)
5646 for (i
= 0; i
< lenc
; i
++)
5648 if (c
->value
.character
.string
[i
]
5649 == e
->value
.character
.string
[indx
- 1])
5658 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
5659 return range_check (result
, "SCAN");
5664 gfc_simplify_selected_char_kind (gfc_expr
*e
)
5668 if (e
->expr_type
!= EXPR_CONSTANT
)
5671 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
5672 || gfc_compare_with_Cstring (e
, "default", false) == 0)
5674 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
5679 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5684 gfc_simplify_selected_int_kind (gfc_expr
*e
)
5688 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
5693 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
5694 if (gfc_integer_kinds
[i
].range
>= range
5695 && gfc_integer_kinds
[i
].kind
< kind
)
5696 kind
= gfc_integer_kinds
[i
].kind
;
5698 if (kind
== INT_MAX
)
5701 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5706 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
5708 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
5710 locus
*loc
= &gfc_current_locus
;
5716 if (p
->expr_type
!= EXPR_CONSTANT
5717 || gfc_extract_int (p
, &precision
) != NULL
)
5726 if (q
->expr_type
!= EXPR_CONSTANT
5727 || gfc_extract_int (q
, &range
) != NULL
)
5738 if (rdx
->expr_type
!= EXPR_CONSTANT
5739 || gfc_extract_int (rdx
, &radix
) != NULL
)
5747 found_precision
= 0;
5751 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5753 if (gfc_real_kinds
[i
].precision
>= precision
)
5754 found_precision
= 1;
5756 if (gfc_real_kinds
[i
].range
>= range
)
5759 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5762 if (gfc_real_kinds
[i
].precision
>= precision
5763 && gfc_real_kinds
[i
].range
>= range
5764 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5765 && gfc_real_kinds
[i
].kind
< kind
)
5766 kind
= gfc_real_kinds
[i
].kind
;
5769 if (kind
== INT_MAX
)
5771 if (found_radix
&& found_range
&& !found_precision
)
5773 else if (found_radix
&& found_precision
&& !found_range
)
5775 else if (found_radix
&& !found_precision
&& !found_range
)
5777 else if (found_radix
)
5783 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
5788 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5791 mpfr_t exp
, absv
, log2
, pow2
, frac
;
5794 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5797 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5799 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
5800 SET_EXPONENT (NaN) = same NaN */
5801 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
5803 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5807 /* SET_EXPONENT (inf) = NaN */
5808 if (mpfr_inf_p (x
->value
.real
))
5810 mpfr_set_nan (result
->value
.real
);
5814 gfc_set_model_kind (x
->ts
.kind
);
5821 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
5822 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
5824 mpfr_trunc (log2
, log2
);
5825 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
5827 /* Old exponent value, and fraction. */
5828 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
5830 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
5833 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
5834 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
5836 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
5838 return range_check (result
, "SET_EXPONENT");
5843 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
5845 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5846 gfc_expr
*result
, *e
, *f
;
5850 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
5852 if (source
->rank
== -1)
5855 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
5857 if (source
->rank
== 0)
5860 if (source
->expr_type
== EXPR_VARIABLE
)
5862 ar
= gfc_find_array_ref (source
);
5863 t
= gfc_array_ref_shape (ar
, shape
);
5865 else if (source
->shape
)
5868 for (n
= 0; n
< source
->rank
; n
++)
5870 mpz_init (shape
[n
]);
5871 mpz_set (shape
[n
], source
->shape
[n
]);
5877 for (n
= 0; n
< source
->rank
; n
++)
5879 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
5882 mpz_set (e
->value
.integer
, shape
[n
]);
5885 mpz_set_ui (e
->value
.integer
, n
+ 1);
5887 f
= simplify_size (source
, e
, k
);
5891 gfc_free_expr (result
);
5898 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
5900 gfc_free_expr (result
);
5902 gfc_clear_shape (shape
, source
->rank
);
5903 return &gfc_bad_expr
;
5906 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
5910 gfc_clear_shape (shape
, source
->rank
);
5917 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
5920 gfc_expr
*return_value
;
5923 /* For unary operations, the size of the result is given by the size
5924 of the operand. For binary ones, it's the size of the first operand
5925 unless it is scalar, then it is the size of the second. */
5926 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
5928 gfc_expr
* replacement
;
5929 gfc_expr
* simplified
;
5931 switch (array
->value
.op
.op
)
5933 /* Unary operations. */
5935 case INTRINSIC_UPLUS
:
5936 case INTRINSIC_UMINUS
:
5937 case INTRINSIC_PARENTHESES
:
5938 replacement
= array
->value
.op
.op1
;
5941 /* Binary operations. If any one of the operands is scalar, take
5942 the other one's size. If both of them are arrays, it does not
5943 matter -- try to find one with known shape, if possible. */
5945 if (array
->value
.op
.op1
->rank
== 0)
5946 replacement
= array
->value
.op
.op2
;
5947 else if (array
->value
.op
.op2
->rank
== 0)
5948 replacement
= array
->value
.op
.op1
;
5951 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
5955 replacement
= array
->value
.op
.op2
;
5960 /* Try to reduce it directly if possible. */
5961 simplified
= simplify_size (replacement
, dim
, k
);
5963 /* Otherwise, we build a new SIZE call. This is hopefully at least
5964 simpler than the original one. */
5967 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
5968 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
5969 GFC_ISYM_SIZE
, "size",
5971 gfc_copy_expr (replacement
),
5972 gfc_copy_expr (dim
),
5980 if (!gfc_array_size (array
, &size
))
5985 if (dim
->expr_type
!= EXPR_CONSTANT
)
5988 d
= mpz_get_ui (dim
->value
.integer
) - 1;
5989 if (!gfc_array_dimen_size (array
, d
, &size
))
5993 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
5994 mpz_set (return_value
->value
.integer
, size
);
5997 return return_value
;
6002 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6005 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
6008 return &gfc_bad_expr
;
6010 result
= simplify_size (array
, dim
, k
);
6011 if (result
== NULL
|| result
== &gfc_bad_expr
)
6014 return range_check (result
, "SIZE");
6018 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
6019 multiplied by the array size. */
6022 gfc_simplify_sizeof (gfc_expr
*x
)
6024 gfc_expr
*result
= NULL
;
6027 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
6030 if (x
->ts
.type
== BT_CHARACTER
6031 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
6032 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
6035 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
6036 && !gfc_array_size (x
, &array_size
))
6039 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
6041 mpz_set_si (result
->value
.integer
, gfc_target_expr_size (x
));
6047 /* STORAGE_SIZE returns the size in bits of a single array element. */
6050 gfc_simplify_storage_size (gfc_expr
*x
,
6053 gfc_expr
*result
= NULL
;
6056 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
6059 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
6060 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
6061 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
6064 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
6066 return &gfc_bad_expr
;
6068 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
6070 mpz_set_si (result
->value
.integer
, gfc_element_size (x
));
6071 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
6073 return range_check (result
, "STORAGE_SIZE");
6078 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
6082 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6085 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6090 mpz_abs (result
->value
.integer
, x
->value
.integer
);
6091 if (mpz_sgn (y
->value
.integer
) < 0)
6092 mpz_neg (result
->value
.integer
, result
->value
.integer
);
6097 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
6100 mpfr_setsign (result
->value
.real
, x
->value
.real
,
6101 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
6105 gfc_internal_error ("Bad type in gfc_simplify_sign");
6113 gfc_simplify_sin (gfc_expr
*x
)
6117 if (x
->expr_type
!= EXPR_CONSTANT
)
6120 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6125 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6129 gfc_set_model (x
->value
.real
);
6130 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6134 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
6137 return range_check (result
, "SIN");
6142 gfc_simplify_sinh (gfc_expr
*x
)
6146 if (x
->expr_type
!= EXPR_CONSTANT
)
6149 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6154 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6158 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6165 return range_check (result
, "SINH");
6169 /* The argument is always a double precision real that is converted to
6170 single precision. TODO: Rounding! */
6173 gfc_simplify_sngl (gfc_expr
*a
)
6177 if (a
->expr_type
!= EXPR_CONSTANT
)
6180 result
= gfc_real2real (a
, gfc_default_real_kind
);
6181 return range_check (result
, "SNGL");
6186 gfc_simplify_spacing (gfc_expr
*x
)
6192 if (x
->expr_type
!= EXPR_CONSTANT
)
6195 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
6196 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
6198 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
6199 if (mpfr_zero_p (x
->value
.real
))
6201 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6205 /* SPACING(inf) = NaN */
6206 if (mpfr_inf_p (x
->value
.real
))
6208 mpfr_set_nan (result
->value
.real
);
6212 /* SPACING(NaN) = same NaN */
6213 if (mpfr_nan_p (x
->value
.real
))
6215 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6219 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
6220 are the radix, exponent of x, and precision. This excludes the
6221 possibility of subnormal numbers. Fortran 2003 states the result is
6222 b**max(e - p, emin - 1). */
6224 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
6225 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
6226 en
= en
> ep
? en
: ep
;
6228 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
6229 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
6231 return range_check (result
, "SPACING");
6236 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
6238 gfc_expr
*result
= NULL
;
6239 int nelem
, i
, j
, dim
, ncopies
;
6242 if ((!gfc_is_constant_expr (source
)
6243 && !is_constant_array_expr (source
))
6244 || !gfc_is_constant_expr (dim_expr
)
6245 || !gfc_is_constant_expr (ncopies_expr
))
6248 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
6249 gfc_extract_int (dim_expr
, &dim
);
6250 dim
-= 1; /* zero-base DIM */
6252 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
6253 gfc_extract_int (ncopies_expr
, &ncopies
);
6254 ncopies
= MAX (ncopies
, 0);
6256 /* Do not allow the array size to exceed the limit for an array
6258 if (source
->expr_type
== EXPR_ARRAY
)
6260 if (!gfc_array_size (source
, &size
))
6261 gfc_internal_error ("Failure getting length of a constant array.");
6264 mpz_init_set_ui (size
, 1);
6266 nelem
= mpz_get_si (size
) * ncopies
;
6267 if (nelem
> flag_max_array_constructor
)
6269 if (gfc_current_ns
->sym_root
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
6271 gfc_error ("The number of elements (%d) in the array constructor "
6272 "at %L requires an increase of the allowed %d upper "
6273 "limit. See %<-fmax-array-constructor%> option.",
6274 nelem
, &source
->where
, flag_max_array_constructor
);
6275 return &gfc_bad_expr
;
6281 if (source
->expr_type
== EXPR_CONSTANT
)
6283 gcc_assert (dim
== 0);
6285 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6287 if (source
->ts
.type
== BT_DERIVED
)
6288 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6290 result
->shape
= gfc_get_shape (result
->rank
);
6291 mpz_init_set_si (result
->shape
[0], ncopies
);
6293 for (i
= 0; i
< ncopies
; ++i
)
6294 gfc_constructor_append_expr (&result
->value
.constructor
,
6295 gfc_copy_expr (source
), NULL
);
6297 else if (source
->expr_type
== EXPR_ARRAY
)
6299 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
6300 gfc_constructor
*source_ctor
;
6302 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
6303 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
6305 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6307 if (source
->ts
.type
== BT_DERIVED
)
6308 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6309 result
->rank
= source
->rank
+ 1;
6310 result
->shape
= gfc_get_shape (result
->rank
);
6312 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
6315 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
6317 mpz_init_set_si (result
->shape
[i
], ncopies
);
6319 extent
[i
] = mpz_get_si (result
->shape
[i
]);
6320 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
6324 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
6325 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
6327 for (i
= 0; i
< ncopies
; ++i
)
6328 gfc_constructor_insert_expr (&result
->value
.constructor
,
6329 gfc_copy_expr (source_ctor
->expr
),
6330 NULL
, offset
+ i
* rstride
[dim
]);
6332 offset
+= (dim
== 0 ? ncopies
: 1);
6337 gfc_error ("Simplification of SPREAD at %C not yet implemented");
6338 return &gfc_bad_expr
;
6341 if (source
->ts
.type
== BT_CHARACTER
)
6342 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
6349 gfc_simplify_sqrt (gfc_expr
*e
)
6351 gfc_expr
*result
= NULL
;
6353 if (e
->expr_type
!= EXPR_CONSTANT
)
6359 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
6361 gfc_error ("Argument of SQRT at %L has a negative value",
6363 return &gfc_bad_expr
;
6365 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6366 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6370 gfc_set_model (e
->value
.real
);
6372 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6373 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
6377 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
6380 return range_check (result
, "SQRT");
6385 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6387 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
6392 gfc_simplify_cotan (gfc_expr
*x
)
6397 if (x
->expr_type
!= EXPR_CONSTANT
)
6400 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6405 mpfr_cot (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6409 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
6410 val
= &result
->value
.complex;
6411 mpc_init2 (swp
, mpfr_get_default_prec ());
6412 mpc_cos (swp
, x
->value
.complex, GFC_MPC_RND_MODE
);
6413 mpc_sin (*val
, x
->value
.complex, GFC_MPC_RND_MODE
);
6414 mpc_div (*val
, swp
, *val
, GFC_MPC_RND_MODE
);
6422 return range_check (result
, "COTAN");
6427 gfc_simplify_tan (gfc_expr
*x
)
6431 if (x
->expr_type
!= EXPR_CONSTANT
)
6434 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6439 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6443 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6450 return range_check (result
, "TAN");
6455 gfc_simplify_tanh (gfc_expr
*x
)
6459 if (x
->expr_type
!= EXPR_CONSTANT
)
6462 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6467 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6471 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6478 return range_check (result
, "TANH");
6483 gfc_simplify_tiny (gfc_expr
*e
)
6488 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
6490 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6491 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6498 gfc_simplify_trailz (gfc_expr
*e
)
6500 unsigned long tz
, bs
;
6503 if (e
->expr_type
!= EXPR_CONSTANT
)
6506 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6507 bs
= gfc_integer_kinds
[i
].bit_size
;
6508 tz
= mpz_scan1 (e
->value
.integer
, 0);
6510 return gfc_get_int_expr (gfc_default_integer_kind
,
6511 &e
->where
, MIN (tz
, bs
));
6516 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6519 gfc_expr
*mold_element
;
6524 unsigned char *buffer
;
6525 size_t result_length
;
6528 if (!gfc_is_constant_expr (source
)
6529 || (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
6530 || !gfc_is_constant_expr (size
))
6533 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6534 &result_size
, &result_length
))
6537 /* Calculate the size of the source. */
6538 if (source
->expr_type
== EXPR_ARRAY
6539 && !gfc_array_size (source
, &tmp
))
6540 gfc_internal_error ("Failure getting length of a constant array.");
6542 /* Create an empty new expression with the appropriate characteristics. */
6543 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
6545 result
->ts
= mold
->ts
;
6547 mold_element
= mold
->expr_type
== EXPR_ARRAY
6548 ? gfc_constructor_first (mold
->value
.constructor
)->expr
6551 /* Set result character length, if needed. Note that this needs to be
6552 set even for array expressions, in order to pass this information into
6553 gfc_target_interpret_expr. */
6554 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
6555 result
->value
.character
.length
= mold_element
->value
.character
.length
;
6557 /* Set the number of elements in the result, and determine its size. */
6559 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
6561 result
->expr_type
= EXPR_ARRAY
;
6563 result
->shape
= gfc_get_shape (1);
6564 mpz_init_set_ui (result
->shape
[0], result_length
);
6569 /* Allocate the buffer to store the binary version of the source. */
6570 buffer_size
= MAX (source_size
, result_size
);
6571 buffer
= (unsigned char*)alloca (buffer_size
);
6572 memset (buffer
, 0, buffer_size
);
6574 /* Now write source to the buffer. */
6575 gfc_target_encode_expr (source
, buffer
, buffer_size
);
6577 /* And read the buffer back into the new expression. */
6578 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
6585 gfc_simplify_transpose (gfc_expr
*matrix
)
6587 int row
, matrix_rows
, col
, matrix_cols
;
6590 if (!is_constant_array_expr (matrix
))
6593 gcc_assert (matrix
->rank
== 2);
6595 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
6598 result
->shape
= gfc_get_shape (result
->rank
);
6599 mpz_set (result
->shape
[0], matrix
->shape
[1]);
6600 mpz_set (result
->shape
[1], matrix
->shape
[0]);
6602 if (matrix
->ts
.type
== BT_CHARACTER
)
6603 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
6604 else if (matrix
->ts
.type
== BT_DERIVED
)
6605 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
6607 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
6608 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
6609 for (row
= 0; row
< matrix_rows
; ++row
)
6610 for (col
= 0; col
< matrix_cols
; ++col
)
6612 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
6613 col
* matrix_rows
+ row
);
6614 gfc_constructor_insert_expr (&result
->value
.constructor
,
6615 gfc_copy_expr (e
), &matrix
->where
,
6616 row
* matrix_cols
+ col
);
6624 gfc_simplify_trim (gfc_expr
*e
)
6627 int count
, i
, len
, lentrim
;
6629 if (e
->expr_type
!= EXPR_CONSTANT
)
6632 len
= e
->value
.character
.length
;
6633 for (count
= 0, i
= 1; i
<= len
; ++i
)
6635 if (e
->value
.character
.string
[len
- i
] == ' ')
6641 lentrim
= len
- count
;
6643 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
6644 for (i
= 0; i
< lentrim
; i
++)
6645 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
6652 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
6657 gfc_constructor
*sub_cons
;
6661 if (!is_constant_array_expr (sub
))
6664 /* Follow any component references. */
6665 as
= coarray
->symtree
->n
.sym
->as
;
6666 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
6667 if (ref
->type
== REF_COMPONENT
)
6670 if (as
->type
== AS_DEFERRED
)
6673 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6674 the cosubscript addresses the first image. */
6676 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
6679 for (d
= 1; d
<= as
->corank
; d
++)
6684 gcc_assert (sub_cons
!= NULL
);
6686 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
6688 if (ca_bound
== NULL
)
6691 if (ca_bound
== &gfc_bad_expr
)
6694 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
6698 gfc_free_expr (ca_bound
);
6699 sub_cons
= gfc_constructor_next (sub_cons
);
6703 first_image
= false;
6707 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6708 "SUB has %ld and COARRAY lower bound is %ld)",
6710 mpz_get_si (sub_cons
->expr
->value
.integer
),
6711 mpz_get_si (ca_bound
->value
.integer
));
6712 gfc_free_expr (ca_bound
);
6713 return &gfc_bad_expr
;
6716 gfc_free_expr (ca_bound
);
6718 /* Check whether upperbound is valid for the multi-images case. */
6721 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
6723 if (ca_bound
== &gfc_bad_expr
)
6726 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
6727 && mpz_cmp (ca_bound
->value
.integer
,
6728 sub_cons
->expr
->value
.integer
) < 0)
6730 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6731 "SUB has %ld and COARRAY upper bound is %ld)",
6733 mpz_get_si (sub_cons
->expr
->value
.integer
),
6734 mpz_get_si (ca_bound
->value
.integer
));
6735 gfc_free_expr (ca_bound
);
6736 return &gfc_bad_expr
;
6740 gfc_free_expr (ca_bound
);
6743 sub_cons
= gfc_constructor_next (sub_cons
);
6746 gcc_assert (sub_cons
== NULL
);
6748 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
6751 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6752 &gfc_current_locus
);
6754 mpz_set_si (result
->value
.integer
, 1);
6756 mpz_set_si (result
->value
.integer
, 0);
6763 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
6764 gfc_expr
*distance ATTRIBUTE_UNUSED
)
6766 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6769 /* If no coarray argument has been passed or when the first argument
6770 is actually a distance argment. */
6771 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
6774 /* FIXME: gfc_current_locus is wrong. */
6775 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6776 &gfc_current_locus
);
6777 mpz_set_si (result
->value
.integer
, 1);
6781 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
6782 return simplify_cobound (coarray
, dim
, NULL
, 0);
6787 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6789 return simplify_bound (array
, dim
, kind
, 1);
6793 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6795 return simplify_cobound (array
, dim
, kind
, 1);
6800 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6802 gfc_expr
*result
, *e
;
6803 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
6805 if (!is_constant_array_expr (vector
)
6806 || !is_constant_array_expr (mask
)
6807 || (!gfc_is_constant_expr (field
)
6808 && !is_constant_array_expr (field
)))
6811 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
6813 if (vector
->ts
.type
== BT_DERIVED
)
6814 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
6815 result
->rank
= mask
->rank
;
6816 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
6818 if (vector
->ts
.type
== BT_CHARACTER
)
6819 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
6821 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
6822 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6824 = field
->expr_type
== EXPR_ARRAY
6825 ? gfc_constructor_first (field
->value
.constructor
)
6830 if (mask_ctor
->expr
->value
.logical
)
6832 gcc_assert (vector_ctor
);
6833 e
= gfc_copy_expr (vector_ctor
->expr
);
6834 vector_ctor
= gfc_constructor_next (vector_ctor
);
6836 else if (field
->expr_type
== EXPR_ARRAY
)
6837 e
= gfc_copy_expr (field_ctor
->expr
);
6839 e
= gfc_copy_expr (field
);
6841 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
6843 mask_ctor
= gfc_constructor_next (mask_ctor
);
6844 field_ctor
= gfc_constructor_next (field_ctor
);
6852 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
6856 size_t index
, len
, lenset
;
6858 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
6861 return &gfc_bad_expr
;
6863 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
6864 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
6867 if (b
!= NULL
&& b
->value
.logical
!= 0)
6872 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
6874 len
= s
->value
.character
.length
;
6875 lenset
= set
->value
.character
.length
;
6879 mpz_set_ui (result
->value
.integer
, 0);
6887 mpz_set_ui (result
->value
.integer
, 1);
6891 index
= wide_strspn (s
->value
.character
.string
,
6892 set
->value
.character
.string
) + 1;
6901 mpz_set_ui (result
->value
.integer
, len
);
6904 for (index
= len
; index
> 0; index
--)
6906 for (i
= 0; i
< lenset
; i
++)
6908 if (s
->value
.character
.string
[index
- 1]
6909 == set
->value
.character
.string
[i
])
6917 mpz_set_ui (result
->value
.integer
, index
);
6923 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
6928 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6931 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6936 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6937 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6938 return range_check (result
, "XOR");
6941 return gfc_get_logical_expr (kind
, &x
->where
,
6942 (x
->value
.logical
&& !y
->value
.logical
)
6943 || (!x
->value
.logical
&& y
->value
.logical
));
6951 /****************** Constant simplification *****************/
6953 /* Master function to convert one constant to another. While this is
6954 used as a simplification function, it requires the destination type
6955 and kind information which is supplied by a special case in
6959 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
6961 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
6976 f
= gfc_int2complex
;
6996 f
= gfc_real2complex
;
7007 f
= gfc_complex2int
;
7010 f
= gfc_complex2real
;
7013 f
= gfc_complex2complex
;
7039 f
= gfc_hollerith2int
;
7043 f
= gfc_hollerith2real
;
7047 f
= gfc_hollerith2complex
;
7051 f
= gfc_hollerith2character
;
7055 f
= gfc_hollerith2logical
;
7065 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
7070 switch (e
->expr_type
)
7073 result
= f (e
, kind
);
7075 return &gfc_bad_expr
;
7079 if (!gfc_is_constant_expr (e
))
7082 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
7083 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
7084 result
->rank
= e
->rank
;
7086 for (c
= gfc_constructor_first (e
->value
.constructor
);
7087 c
; c
= gfc_constructor_next (c
))
7090 if (c
->iterator
== NULL
)
7091 tmp
= f (c
->expr
, kind
);
7094 g
= gfc_convert_constant (c
->expr
, type
, kind
);
7095 if (g
== &gfc_bad_expr
)
7097 gfc_free_expr (result
);
7105 gfc_free_expr (result
);
7109 gfc_constructor_append_expr (&result
->value
.constructor
,
7123 /* Function for converting character constants. */
7125 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
7130 if (!gfc_is_constant_expr (e
))
7133 if (e
->expr_type
== EXPR_CONSTANT
)
7135 /* Simple case of a scalar. */
7136 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
7138 return &gfc_bad_expr
;
7140 result
->value
.character
.length
= e
->value
.character
.length
;
7141 result
->value
.character
.string
7142 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
7143 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
7144 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
7146 /* Check we only have values representable in the destination kind. */
7147 for (i
= 0; i
< result
->value
.character
.length
; i
++)
7148 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
7151 gfc_error ("Character %qs in string at %L cannot be converted "
7152 "into character kind %d",
7153 gfc_print_wide_char (result
->value
.character
.string
[i
]),
7155 gfc_free_expr (result
);
7156 return &gfc_bad_expr
;
7161 else if (e
->expr_type
== EXPR_ARRAY
)
7163 /* For an array constructor, we convert each constructor element. */
7166 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
7167 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
7168 result
->rank
= e
->rank
;
7169 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
7171 for (c
= gfc_constructor_first (e
->value
.constructor
);
7172 c
; c
= gfc_constructor_next (c
))
7174 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
7175 if (tmp
== &gfc_bad_expr
)
7177 gfc_free_expr (result
);
7178 return &gfc_bad_expr
;
7183 gfc_free_expr (result
);
7187 gfc_constructor_append_expr (&result
->value
.constructor
,
7199 gfc_simplify_compiler_options (void)
7204 str
= gfc_get_option_string ();
7205 result
= gfc_get_character_expr (gfc_default_character_kind
,
7206 &gfc_current_locus
, str
, strlen (str
));
7213 gfc_simplify_compiler_version (void)
7218 len
= strlen ("GCC version ") + strlen (version_string
);
7219 buffer
= XALLOCAVEC (char, len
+ 1);
7220 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
7221 return gfc_get_character_expr (gfc_default_character_kind
,
7222 &gfc_current_locus
, buffer
, len
);
7225 /* Simplification routines for intrinsics of IEEE modules. */
7228 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
7230 gfc_actual_arglist
*arg
;
7231 gfc_expr
*p
= NULL
, *q
= NULL
, *rdx
= NULL
;
7233 arg
= expr
->value
.function
.actual
;
7237 q
= arg
->next
->expr
;
7238 if (arg
->next
->next
)
7239 rdx
= arg
->next
->next
->expr
;
7242 /* Currently, if IEEE is supported and this module is built, it means
7243 all our floating-point types conform to IEEE. Hence, we simply handle
7244 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
7245 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
7249 simplify_ieee_support (gfc_expr
*expr
)
7251 /* We consider that if the IEEE modules are loaded, we have full support
7252 for flags, halting and rounding, which are the three functions
7253 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
7254 expressions. One day, we will need libgfortran to detect support and
7255 communicate it back to us, allowing for partial support. */
7257 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
7262 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
7264 int n
= strlen(name
);
7266 if (!strncmp(sym
->name
, name
, n
))
7269 /* If a generic was used and renamed, we need more work to find out.
7270 Compare the specific name. */
7271 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
7278 gfc_simplify_ieee_functions (gfc_expr
*expr
)
7280 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
7282 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
7283 return simplify_ieee_selected_real_kind (expr
);
7284 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
7285 || matches_ieee_function_name(sym
, "ieee_support_halting")
7286 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
7287 return simplify_ieee_support (expr
);