1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2016 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
24 #include "tm.h" /* For BITS_PER_UNIT. */
27 #include "intrinsic.h"
28 #include "target-memory.h"
29 #include "constructor.h"
30 #include "version.h" /* For version_string. */
33 gfc_expr gfc_bad_expr
;
35 static gfc_expr
*simplify_size (gfc_expr
*, gfc_expr
*, int);
38 /* Note that 'simplification' is not just transforming expressions.
39 For functions that are not simplified at compile time, range
40 checking is done if possible.
42 The return convention is that each simplification function returns:
44 A new expression node corresponding to the simplified arguments.
45 The original arguments are destroyed by the caller, and must not
46 be a part of the new expression.
48 NULL pointer indicating that no simplification was possible and
49 the original expression should remain intact.
51 An expression pointer to gfc_bad_expr (a static placeholder)
52 indicating that some error has prevented simplification. The
53 error is generated within the function and should be propagated
56 By the time a simplification function gets control, it has been
57 decided that the function call is really supposed to be the
58 intrinsic. No type checking is strictly necessary, since only
59 valid types will be passed on. On the other hand, a simplification
60 subroutine may have to look at the type of an argument as part of
63 Array arguments are only passed to these subroutines that implement
64 the simplification of transformational intrinsics.
66 The functions in this file don't have much comment with them, but
67 everything is reasonably straight-forward. The Standard, chapter 13
68 is the best comment you'll find for this file anyway. */
70 /* Range checks an expression node. If all goes well, returns the
71 node, otherwise returns &gfc_bad_expr and frees the node. */
74 range_check (gfc_expr
*result
, const char *name
)
79 if (result
->expr_type
!= EXPR_CONSTANT
)
82 switch (gfc_range_check (result
))
88 gfc_error ("Result of %s overflows its kind at %L", name
,
93 gfc_error ("Result of %s underflows its kind at %L", name
,
98 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
102 gfc_error ("Result of %s gives range error for its kind at %L", name
,
107 gfc_free_expr (result
);
108 return &gfc_bad_expr
;
112 /* A helper function that gets an optional and possibly missing
113 kind parameter. Returns the kind, -1 if something went wrong. */
116 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
123 if (k
->expr_type
!= EXPR_CONSTANT
)
125 gfc_error ("KIND parameter of %s at %L must be an initialization "
126 "expression", name
, &k
->where
);
130 if (gfc_extract_int (k
, &kind
) != NULL
131 || gfc_validate_kind (type
, kind
, true) < 0)
133 gfc_error ("Invalid KIND parameter of %s at %L", name
, &k
->where
);
141 /* Converts an mpz_t signed variable into an unsigned one, assuming
142 two's complement representations and a binary width of bitsize.
143 The conversion is a no-op unless x is negative; otherwise, it can
144 be accomplished by masking out the high bits. */
147 convert_mpz_to_unsigned (mpz_t x
, int bitsize
)
153 /* Confirm that no bits above the signed range are unset if we
154 are doing range checking. */
155 if (flag_range_check
!= 0)
156 gcc_assert (mpz_scan0 (x
, bitsize
-1) == ULONG_MAX
);
158 mpz_init_set_ui (mask
, 1);
159 mpz_mul_2exp (mask
, mask
, bitsize
);
160 mpz_sub_ui (mask
, mask
, 1);
162 mpz_and (x
, x
, mask
);
168 /* Confirm that no bits above the signed range are set. */
169 gcc_assert (mpz_scan1 (x
, bitsize
-1) == ULONG_MAX
);
174 /* Converts an mpz_t unsigned variable into a signed one, assuming
175 two's complement representations and a binary width of bitsize.
176 If the bitsize-1 bit is set, this is taken as a sign bit and
177 the number is converted to the corresponding negative number. */
180 gfc_convert_mpz_to_signed (mpz_t x
, int bitsize
)
184 /* Confirm that no bits above the unsigned range are set if we are
185 doing range checking. */
186 if (flag_range_check
!= 0)
187 gcc_assert (mpz_scan1 (x
, bitsize
) == ULONG_MAX
);
189 if (mpz_tstbit (x
, bitsize
- 1) == 1)
191 mpz_init_set_ui (mask
, 1);
192 mpz_mul_2exp (mask
, mask
, bitsize
);
193 mpz_sub_ui (mask
, mask
, 1);
195 /* We negate the number by hand, zeroing the high bits, that is
196 make it the corresponding positive number, and then have it
197 negated by GMP, giving the correct representation of the
200 mpz_add_ui (x
, x
, 1);
201 mpz_and (x
, x
, mask
);
210 /* In-place convert BOZ to REAL of the specified kind. */
213 convert_boz (gfc_expr
*x
, int kind
)
215 if (x
&& x
->ts
.type
== BT_INTEGER
&& x
->is_boz
)
222 if (!gfc_convert_boz (x
, &ts
))
223 return &gfc_bad_expr
;
230 /* Test that the expression is an constant array. */
233 is_constant_array_expr (gfc_expr
*e
)
240 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
243 for (c
= gfc_constructor_first (e
->value
.constructor
);
244 c
; c
= gfc_constructor_next (c
))
245 if (c
->expr
->expr_type
!= EXPR_CONSTANT
246 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
253 /* Initialize a transformational result expression with a given value. */
256 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
258 if (e
&& e
->expr_type
== EXPR_ARRAY
)
260 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
263 init_result_expr (ctor
->expr
, init
, array
);
264 ctor
= gfc_constructor_next (ctor
);
267 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
269 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
276 e
->value
.logical
= (init
? 1 : 0);
281 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
282 else if (init
== INT_MAX
)
283 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
285 mpz_set_si (e
->value
.integer
, init
);
291 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
292 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
294 else if (init
== INT_MAX
)
295 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
297 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
301 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
307 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
308 gfc_extract_int (len
, &length
);
309 string
= gfc_get_wide_string (length
+ 1);
310 gfc_wide_memset (string
, 0, length
);
312 else if (init
== INT_MAX
)
314 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
315 gfc_extract_int (len
, &length
);
316 string
= gfc_get_wide_string (length
+ 1);
317 gfc_wide_memset (string
, 255, length
);
322 string
= gfc_get_wide_string (1);
325 string
[length
] = '\0';
326 e
->value
.character
.length
= length
;
327 e
->value
.character
.string
= string
;
339 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
340 if conj_a is true, the matrix_a is complex conjugated. */
343 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
344 gfc_expr
*matrix_b
, int stride_b
, int offset_b
,
347 gfc_expr
*result
, *a
, *b
, *c
;
349 result
= gfc_get_constant_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
351 init_result_expr (result
, 0, NULL
);
353 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
354 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
357 /* Copying of expressions is required as operands are free'd
358 by the gfc_arith routines. */
359 switch (result
->ts
.type
)
362 result
= gfc_or (result
,
363 gfc_and (gfc_copy_expr (a
),
370 if (conj_a
&& a
->ts
.type
== BT_COMPLEX
)
371 c
= gfc_simplify_conjg (a
);
373 c
= gfc_copy_expr (a
);
374 result
= gfc_add (result
, gfc_multiply (c
, gfc_copy_expr (b
)));
381 offset_a
+= stride_a
;
382 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
384 offset_b
+= stride_b
;
385 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
392 /* Build a result expression for transformational intrinsics,
396 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
397 int kind
, locus
* where
)
402 if (!dim
|| array
->rank
== 1)
403 return gfc_get_constant_expr (type
, kind
, where
);
405 result
= gfc_get_array_expr (type
, kind
, where
);
406 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
407 result
->rank
= array
->rank
- 1;
409 /* gfc_array_size() would count the number of elements in the constructor,
410 we have not built those yet. */
412 for (i
= 0; i
< result
->rank
; ++i
)
413 nelem
*= mpz_get_ui (result
->shape
[i
]);
415 for (i
= 0; i
< nelem
; ++i
)
417 gfc_constructor_append_expr (&result
->value
.constructor
,
418 gfc_get_constant_expr (type
, kind
, where
),
426 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
428 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
429 of COUNT intrinsic is .TRUE..
431 Interface and implementation mimics arith functions as
432 gfc_add, gfc_multiply, etc. */
434 static gfc_expr
* gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
438 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
439 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
440 gcc_assert (op2
->value
.logical
);
442 result
= gfc_copy_expr (op1
);
443 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
451 /* Transforms an ARRAY with operation OP, according to MASK, to a
452 scalar RESULT. E.g. called if
454 REAL, PARAMETER :: array(n, m) = ...
455 REAL, PARAMETER :: s = SUM(array)
457 where OP == gfc_add(). */
460 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
461 transformational_op op
)
464 gfc_constructor
*array_ctor
, *mask_ctor
;
466 /* Shortcut for constant .FALSE. MASK. */
468 && mask
->expr_type
== EXPR_CONSTANT
469 && !mask
->value
.logical
)
472 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
474 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
475 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
479 a
= array_ctor
->expr
;
480 array_ctor
= gfc_constructor_next (array_ctor
);
482 /* A constant MASK equals .TRUE. here and can be ignored. */
486 mask_ctor
= gfc_constructor_next (mask_ctor
);
487 if (!m
->value
.logical
)
491 result
= op (result
, gfc_copy_expr (a
));
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 the same. */
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
2531 mold
->ts
.u
.derived
->components
->ts
.u
.derived
)
2532 && !gfc_type_is_extension_of
2533 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2535 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
2536 && !gfc_type_is_extension_of
2537 (mold
->ts
.u
.derived
,
2538 a
->ts
.u
.derived
->components
->ts
.u
.derived
)))
2539 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2541 if (mold
->ts
.type
== BT_DERIVED
2542 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2543 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
2544 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
2551 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
2553 /* Avoid simplification of resolved symbols. */
2554 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
2557 /* Return .false. if the dynamic type can never be the
2559 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
2560 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
2561 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
2562 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
2563 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2565 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
2568 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2569 gfc_compare_derived_types (a
->ts
.u
.derived
,
2575 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
2581 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
2583 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2585 if (e
->expr_type
!= EXPR_CONSTANT
)
2588 mpfr_init2 (floor
, mpfr_get_prec (e
->value
.real
));
2589 mpfr_floor (floor
, e
->value
.real
);
2591 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
2592 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
2596 return range_check (result
, "FLOOR");
2601 gfc_simplify_fraction (gfc_expr
*x
)
2605 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2606 mpfr_t absv
, exp
, pow2
;
2611 if (x
->expr_type
!= EXPR_CONSTANT
)
2614 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
2616 /* FRACTION(inf) = NaN. */
2617 if (mpfr_inf_p (x
->value
.real
))
2619 mpfr_set_nan (result
->value
.real
);
2623 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2625 /* MPFR versions before 3.1.0 do not include mpfr_frexp.
2626 TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
2628 if (mpfr_sgn (x
->value
.real
) == 0)
2630 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2634 gfc_set_model_kind (x
->ts
.kind
);
2639 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
2640 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
2642 mpfr_trunc (exp
, exp
);
2643 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
2645 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
2647 mpfr_div (result
->value
.real
, x
->value
.real
, pow2
, GFC_RND_MODE
);
2649 mpfr_clears (exp
, absv
, pow2
, NULL
);
2653 /* mpfr_frexp() correctly handles zeros and NaNs. */
2654 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2658 return range_check (result
, "FRACTION");
2663 gfc_simplify_gamma (gfc_expr
*x
)
2667 if (x
->expr_type
!= EXPR_CONSTANT
)
2670 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2671 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2673 return range_check (result
, "GAMMA");
2678 gfc_simplify_huge (gfc_expr
*e
)
2683 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2684 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2689 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2693 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
2705 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
2709 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2712 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2713 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
2714 return range_check (result
, "HYPOT");
2718 /* We use the processor's collating sequence, because all
2719 systems that gfortran currently works on are ASCII. */
2722 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
2728 if (e
->expr_type
!= EXPR_CONSTANT
)
2731 if (e
->value
.character
.length
!= 1)
2733 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
2734 return &gfc_bad_expr
;
2737 index
= e
->value
.character
.string
[0];
2739 if (warn_surprising
&& index
> 127)
2740 gfc_warning (OPT_Wsurprising
,
2741 "Argument of IACHAR function at %L outside of range 0..127",
2744 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
2746 return &gfc_bad_expr
;
2748 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2750 return range_check (result
, "IACHAR");
2755 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
2757 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2758 gcc_assert (result
->ts
.type
== BT_INTEGER
2759 && result
->expr_type
== EXPR_CONSTANT
);
2761 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2767 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2769 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
2774 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
2776 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2777 gcc_assert (result
->ts
.type
== BT_INTEGER
2778 && result
->expr_type
== EXPR_CONSTANT
);
2780 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2786 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2788 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
2793 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
2797 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2800 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2801 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2803 return range_check (result
, "IAND");
2808 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
2813 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2816 gfc_extract_int (y
, &pos
);
2818 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2820 result
= gfc_copy_expr (x
);
2822 convert_mpz_to_unsigned (result
->value
.integer
,
2823 gfc_integer_kinds
[k
].bit_size
);
2825 mpz_clrbit (result
->value
.integer
, pos
);
2827 gfc_convert_mpz_to_signed (result
->value
.integer
,
2828 gfc_integer_kinds
[k
].bit_size
);
2835 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
2842 if (x
->expr_type
!= EXPR_CONSTANT
2843 || y
->expr_type
!= EXPR_CONSTANT
2844 || z
->expr_type
!= EXPR_CONSTANT
)
2847 gfc_extract_int (y
, &pos
);
2848 gfc_extract_int (z
, &len
);
2850 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
2852 bitsize
= gfc_integer_kinds
[k
].bit_size
;
2854 if (pos
+ len
> bitsize
)
2856 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2857 "bit size at %L", &y
->where
);
2858 return &gfc_bad_expr
;
2861 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2862 convert_mpz_to_unsigned (result
->value
.integer
,
2863 gfc_integer_kinds
[k
].bit_size
);
2865 bits
= XCNEWVEC (int, bitsize
);
2867 for (i
= 0; i
< bitsize
; i
++)
2870 for (i
= 0; i
< len
; i
++)
2871 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
2873 for (i
= 0; i
< bitsize
; i
++)
2876 mpz_clrbit (result
->value
.integer
, i
);
2877 else if (bits
[i
] == 1)
2878 mpz_setbit (result
->value
.integer
, i
);
2880 gfc_internal_error ("IBITS: Bad bit");
2885 gfc_convert_mpz_to_signed (result
->value
.integer
,
2886 gfc_integer_kinds
[k
].bit_size
);
2893 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
2898 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2901 gfc_extract_int (y
, &pos
);
2903 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2905 result
= gfc_copy_expr (x
);
2907 convert_mpz_to_unsigned (result
->value
.integer
,
2908 gfc_integer_kinds
[k
].bit_size
);
2910 mpz_setbit (result
->value
.integer
, pos
);
2912 gfc_convert_mpz_to_signed (result
->value
.integer
,
2913 gfc_integer_kinds
[k
].bit_size
);
2920 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
2926 if (e
->expr_type
!= EXPR_CONSTANT
)
2929 if (e
->value
.character
.length
!= 1)
2931 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
2932 return &gfc_bad_expr
;
2935 index
= e
->value
.character
.string
[0];
2937 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
2939 return &gfc_bad_expr
;
2941 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2943 return range_check (result
, "ICHAR");
2948 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
2952 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2955 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2956 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2958 return range_check (result
, "IEOR");
2963 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
2966 int back
, len
, lensub
;
2967 int i
, j
, k
, count
, index
= 0, start
;
2969 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
2970 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
2973 if (b
!= NULL
&& b
->value
.logical
!= 0)
2978 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
2980 return &gfc_bad_expr
;
2982 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
2984 len
= x
->value
.character
.length
;
2985 lensub
= y
->value
.character
.length
;
2989 mpz_set_si (result
->value
.integer
, 0);
2997 mpz_set_si (result
->value
.integer
, 1);
3000 else if (lensub
== 1)
3002 for (i
= 0; i
< len
; i
++)
3004 for (j
= 0; j
< lensub
; j
++)
3006 if (y
->value
.character
.string
[j
]
3007 == x
->value
.character
.string
[i
])
3017 for (i
= 0; i
< len
; i
++)
3019 for (j
= 0; j
< lensub
; j
++)
3021 if (y
->value
.character
.string
[j
]
3022 == x
->value
.character
.string
[i
])
3027 for (k
= 0; k
< lensub
; k
++)
3029 if (y
->value
.character
.string
[k
]
3030 == x
->value
.character
.string
[k
+ start
])
3034 if (count
== lensub
)
3049 mpz_set_si (result
->value
.integer
, len
+ 1);
3052 else if (lensub
== 1)
3054 for (i
= 0; i
< len
; i
++)
3056 for (j
= 0; j
< lensub
; j
++)
3058 if (y
->value
.character
.string
[j
]
3059 == x
->value
.character
.string
[len
- i
])
3061 index
= len
- i
+ 1;
3069 for (i
= 0; i
< len
; i
++)
3071 for (j
= 0; j
< lensub
; j
++)
3073 if (y
->value
.character
.string
[j
]
3074 == x
->value
.character
.string
[len
- i
])
3077 if (start
<= len
- lensub
)
3080 for (k
= 0; k
< lensub
; k
++)
3081 if (y
->value
.character
.string
[k
]
3082 == x
->value
.character
.string
[k
+ start
])
3085 if (count
== lensub
)
3102 mpz_set_si (result
->value
.integer
, index
);
3103 return range_check (result
, "INDEX");
3108 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
3110 gfc_expr
*result
= NULL
;
3112 if (e
->expr_type
!= EXPR_CONSTANT
)
3115 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
3116 if (result
== &gfc_bad_expr
)
3117 return &gfc_bad_expr
;
3119 return range_check (result
, name
);
3124 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
3128 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
3130 return &gfc_bad_expr
;
3132 return simplify_intconv (e
, kind
, "INT");
3136 gfc_simplify_int2 (gfc_expr
*e
)
3138 return simplify_intconv (e
, 2, "INT2");
3143 gfc_simplify_int8 (gfc_expr
*e
)
3145 return simplify_intconv (e
, 8, "INT8");
3150 gfc_simplify_long (gfc_expr
*e
)
3152 return simplify_intconv (e
, 4, "LONG");
3157 gfc_simplify_ifix (gfc_expr
*e
)
3159 gfc_expr
*rtrunc
, *result
;
3161 if (e
->expr_type
!= EXPR_CONSTANT
)
3164 rtrunc
= gfc_copy_expr (e
);
3165 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3167 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3169 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3171 gfc_free_expr (rtrunc
);
3173 return range_check (result
, "IFIX");
3178 gfc_simplify_idint (gfc_expr
*e
)
3180 gfc_expr
*rtrunc
, *result
;
3182 if (e
->expr_type
!= EXPR_CONSTANT
)
3185 rtrunc
= gfc_copy_expr (e
);
3186 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3188 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3190 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3192 gfc_free_expr (rtrunc
);
3194 return range_check (result
, "IDINT");
3199 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
3203 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3206 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3207 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3209 return range_check (result
, "IOR");
3214 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
3216 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3217 gcc_assert (result
->ts
.type
== BT_INTEGER
3218 && result
->expr_type
== EXPR_CONSTANT
);
3220 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3226 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3228 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3233 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3235 if (x
->expr_type
!= EXPR_CONSTANT
)
3238 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3239 mpz_cmp_si (x
->value
.integer
,
3240 LIBERROR_END
) == 0);
3245 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3247 if (x
->expr_type
!= EXPR_CONSTANT
)
3250 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3251 mpz_cmp_si (x
->value
.integer
,
3252 LIBERROR_EOR
) == 0);
3257 gfc_simplify_isnan (gfc_expr
*x
)
3259 if (x
->expr_type
!= EXPR_CONSTANT
)
3262 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3263 mpfr_nan_p (x
->value
.real
));
3267 /* Performs a shift on its first argument. Depending on the last
3268 argument, the shift can be arithmetic, i.e. with filling from the
3269 left like in the SHIFTA intrinsic. */
3271 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3272 bool arithmetic
, int direction
)
3275 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3277 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3280 gfc_extract_int (s
, &shift
);
3282 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3283 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3285 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3289 mpz_set (result
->value
.integer
, e
->value
.integer
);
3293 if (direction
> 0 && shift
< 0)
3295 /* Left shift, as in SHIFTL. */
3296 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3297 return &gfc_bad_expr
;
3299 else if (direction
< 0)
3301 /* Right shift, as in SHIFTR or SHIFTA. */
3304 gfc_error ("Second argument of %s is negative at %L",
3306 return &gfc_bad_expr
;
3312 ashift
= (shift
>= 0 ? shift
: -shift
);
3314 if (ashift
> bitsize
)
3316 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3317 "at %L", name
, &e
->where
);
3318 return &gfc_bad_expr
;
3321 bits
= XCNEWVEC (int, bitsize
);
3323 for (i
= 0; i
< bitsize
; i
++)
3324 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3329 for (i
= 0; i
< shift
; i
++)
3330 mpz_clrbit (result
->value
.integer
, i
);
3332 for (i
= 0; i
< bitsize
- shift
; i
++)
3335 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3337 mpz_setbit (result
->value
.integer
, i
+ shift
);
3343 if (arithmetic
&& bits
[bitsize
- 1])
3344 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3345 mpz_setbit (result
->value
.integer
, i
);
3347 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3348 mpz_clrbit (result
->value
.integer
, i
);
3350 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3353 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3355 mpz_setbit (result
->value
.integer
, i
- ashift
);
3359 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3367 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3369 return simplify_shift (e
, s
, "ISHFT", false, 0);
3374 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3376 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3381 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3383 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3388 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3390 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3395 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3397 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3402 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3404 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3409 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3412 int shift
, ashift
, isize
, ssize
, delta
, k
;
3415 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3418 gfc_extract_int (s
, &shift
);
3420 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3421 isize
= gfc_integer_kinds
[k
].bit_size
;
3425 if (sz
->expr_type
!= EXPR_CONSTANT
)
3428 gfc_extract_int (sz
, &ssize
);
3441 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3442 "BIT_SIZE of first argument at %C");
3444 gfc_error ("Absolute value of SHIFT shall be less than or equal "
3446 return &gfc_bad_expr
;
3449 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3451 mpz_set (result
->value
.integer
, e
->value
.integer
);
3456 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
3458 bits
= XCNEWVEC (int, ssize
);
3460 for (i
= 0; i
< ssize
; i
++)
3461 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3463 delta
= ssize
- ashift
;
3467 for (i
= 0; i
< delta
; i
++)
3470 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3472 mpz_setbit (result
->value
.integer
, i
+ shift
);
3475 for (i
= delta
; i
< ssize
; i
++)
3478 mpz_clrbit (result
->value
.integer
, i
- delta
);
3480 mpz_setbit (result
->value
.integer
, i
- delta
);
3485 for (i
= 0; i
< ashift
; i
++)
3488 mpz_clrbit (result
->value
.integer
, i
+ delta
);
3490 mpz_setbit (result
->value
.integer
, i
+ delta
);
3493 for (i
= ashift
; i
< ssize
; i
++)
3496 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3498 mpz_setbit (result
->value
.integer
, i
+ shift
);
3502 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
3510 gfc_simplify_kind (gfc_expr
*e
)
3512 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
3517 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
3518 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
3520 gfc_expr
*l
, *u
, *result
;
3523 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3524 gfc_default_integer_kind
);
3526 return &gfc_bad_expr
;
3528 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3530 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3531 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3532 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
3536 gfc_expr
* dim
= result
;
3537 mpz_set_si (dim
->value
.integer
, d
);
3539 result
= simplify_size (array
, dim
, k
);
3540 gfc_free_expr (dim
);
3545 mpz_set_si (result
->value
.integer
, 1);
3550 /* Otherwise, we have a variable expression. */
3551 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
3554 if (!gfc_resolve_array_spec (as
, 0))
3557 /* The last dimension of an assumed-size array is special. */
3558 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
3559 || (coarray
&& d
== as
->rank
+ as
->corank
3560 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
3562 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
3564 gfc_free_expr (result
);
3565 return gfc_copy_expr (as
->lower
[d
-1]);
3571 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3573 /* Then, we need to know the extent of the given dimension. */
3574 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
3576 gfc_expr
*declared_bound
;
3578 bool constant_lbound
, constant_ubound
;
3583 gcc_assert (l
!= NULL
);
3585 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
3586 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
3588 empty_bound
= upper
? 0 : 1;
3589 declared_bound
= upper
? u
: l
;
3591 if ((!upper
&& !constant_lbound
)
3592 || (upper
&& !constant_ubound
))
3597 /* For {L,U}BOUND, the value depends on whether the array
3598 is empty. We can nevertheless simplify if the declared bound
3599 has the same value as that of an empty array, in which case
3600 the result isn't dependent on the array emptyness. */
3601 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
3602 mpz_set_si (result
->value
.integer
, empty_bound
);
3603 else if (!constant_lbound
|| !constant_ubound
)
3604 /* Array emptyness can't be determined, we can't simplify. */
3606 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
3607 mpz_set_si (result
->value
.integer
, empty_bound
);
3609 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
3612 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
3618 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d
- 1, &result
->value
.integer
, NULL
))
3622 mpz_set_si (result
->value
.integer
, (long int) 1);
3626 return range_check (result
, upper
? "UBOUND" : "LBOUND");
3629 gfc_free_expr (result
);
3635 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3641 if (array
->ts
.type
== BT_CLASS
)
3644 if (array
->expr_type
!= EXPR_VARIABLE
)
3651 /* Follow any component references. */
3652 as
= array
->symtree
->n
.sym
->as
;
3653 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3658 switch (ref
->u
.ar
.type
)
3665 /* We're done because 'as' has already been set in the
3666 previous iteration. */
3680 as
= ref
->u
.c
.component
->as
;
3692 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
3693 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
3697 || (as
->type
!= AS_DEFERRED
3698 && array
->expr_type
== EXPR_VARIABLE
3699 && !gfc_expr_attr (array
).allocatable
3700 && !gfc_expr_attr (array
).pointer
));
3704 /* Multi-dimensional bounds. */
3705 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3709 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
3710 if (upper
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
3712 /* An error message will be emitted in
3713 check_assumed_size_reference (resolve.c). */
3714 return &gfc_bad_expr
;
3717 /* Simplify the bounds for each dimension. */
3718 for (d
= 0; d
< array
->rank
; d
++)
3720 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
3722 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3726 for (j
= 0; j
< d
; j
++)
3727 gfc_free_expr (bounds
[j
]);
3732 /* Allocate the result expression. */
3733 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3734 gfc_default_integer_kind
);
3736 return &gfc_bad_expr
;
3738 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
3740 /* The result is a rank 1 array; its size is the rank of the first
3741 argument to {L,U}BOUND. */
3743 e
->shape
= gfc_get_shape (1);
3744 mpz_init_set_ui (e
->shape
[0], array
->rank
);
3746 /* Create the constructor for this array. */
3747 for (d
= 0; d
< array
->rank
; d
++)
3748 gfc_constructor_append_expr (&e
->value
.constructor
,
3749 bounds
[d
], &e
->where
);
3755 /* A DIM argument is specified. */
3756 if (dim
->expr_type
!= EXPR_CONSTANT
)
3759 d
= mpz_get_si (dim
->value
.integer
);
3761 if ((d
< 1 || d
> array
->rank
)
3762 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
3764 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3765 return &gfc_bad_expr
;
3768 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3771 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
3777 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3783 if (array
->expr_type
!= EXPR_VARIABLE
)
3786 /* Follow any component references. */
3787 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
3788 ? array
->ts
.u
.derived
->components
->as
3789 : array
->symtree
->n
.sym
->as
;
3790 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3795 switch (ref
->u
.ar
.type
)
3798 if (ref
->u
.ar
.as
->corank
> 0)
3800 gcc_assert (as
== ref
->u
.ar
.as
);
3807 /* We're done because 'as' has already been set in the
3808 previous iteration. */
3822 as
= ref
->u
.c
.component
->as
;
3835 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
3840 /* Multi-dimensional cobounds. */
3841 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3845 /* Simplify the cobounds for each dimension. */
3846 for (d
= 0; d
< as
->corank
; d
++)
3848 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
3849 upper
, as
, ref
, true);
3850 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3854 for (j
= 0; j
< d
; j
++)
3855 gfc_free_expr (bounds
[j
]);
3860 /* Allocate the result expression. */
3861 e
= gfc_get_expr ();
3862 e
->where
= array
->where
;
3863 e
->expr_type
= EXPR_ARRAY
;
3864 e
->ts
.type
= BT_INTEGER
;
3865 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
3866 gfc_default_integer_kind
);
3870 return &gfc_bad_expr
;
3874 /* The result is a rank 1 array; its size is the rank of the first
3875 argument to {L,U}COBOUND. */
3877 e
->shape
= gfc_get_shape (1);
3878 mpz_init_set_ui (e
->shape
[0], as
->corank
);
3880 /* Create the constructor for this array. */
3881 for (d
= 0; d
< as
->corank
; d
++)
3882 gfc_constructor_append_expr (&e
->value
.constructor
,
3883 bounds
[d
], &e
->where
);
3888 /* A DIM argument is specified. */
3889 if (dim
->expr_type
!= EXPR_CONSTANT
)
3892 d
= mpz_get_si (dim
->value
.integer
);
3894 if (d
< 1 || d
> as
->corank
)
3896 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3897 return &gfc_bad_expr
;
3900 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
3906 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3908 return simplify_bound (array
, dim
, kind
, 0);
3913 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3915 return simplify_cobound (array
, dim
, kind
, 0);
3919 gfc_simplify_leadz (gfc_expr
*e
)
3921 unsigned long lz
, bs
;
3924 if (e
->expr_type
!= EXPR_CONSTANT
)
3927 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3928 bs
= gfc_integer_kinds
[i
].bit_size
;
3929 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
3931 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
3934 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
3936 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
3941 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
3944 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
3947 return &gfc_bad_expr
;
3949 if (e
->expr_type
== EXPR_CONSTANT
)
3951 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3952 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
3953 return range_check (result
, "LEN");
3955 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
3956 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3957 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
3959 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3960 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
3961 return range_check (result
, "LEN");
3963 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
3964 && e
->symtree
->n
.sym
3965 && e
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
3966 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
3967 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
3968 && e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
3969 && UNLIMITED_POLY (e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
))
3971 /* The expression in assoc->target points to a ref to the _data component
3972 of the unlimited polymorphic entity. To get the _len component the last
3973 _data ref needs to be stripped and a ref to the _len component added. */
3974 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
);
3981 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
3985 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
3988 return &gfc_bad_expr
;
3990 if (e
->expr_type
!= EXPR_CONSTANT
)
3993 len
= e
->value
.character
.length
;
3994 for (count
= 0, i
= 1; i
<= len
; i
++)
3995 if (e
->value
.character
.string
[len
- i
] == ' ')
4000 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
4001 return range_check (result
, "LEN_TRIM");
4005 gfc_simplify_lgamma (gfc_expr
*x
)
4010 if (x
->expr_type
!= EXPR_CONSTANT
)
4013 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4014 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
4016 return range_check (result
, "LGAMMA");
4021 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
4023 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4026 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4027 gfc_compare_string (a
, b
) >= 0);
4032 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
4034 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4037 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4038 gfc_compare_string (a
, b
) > 0);
4043 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
4045 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4048 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4049 gfc_compare_string (a
, b
) <= 0);
4054 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
4056 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4059 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4060 gfc_compare_string (a
, b
) < 0);
4065 gfc_simplify_log (gfc_expr
*x
)
4069 if (x
->expr_type
!= EXPR_CONSTANT
)
4072 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4077 if (mpfr_sgn (x
->value
.real
) <= 0)
4079 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4080 "to zero", &x
->where
);
4081 gfc_free_expr (result
);
4082 return &gfc_bad_expr
;
4085 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4089 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
4090 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
4092 gfc_error ("Complex argument of LOG at %L cannot be zero",
4094 gfc_free_expr (result
);
4095 return &gfc_bad_expr
;
4098 gfc_set_model_kind (x
->ts
.kind
);
4099 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
4103 gfc_internal_error ("gfc_simplify_log: bad type");
4106 return range_check (result
, "LOG");
4111 gfc_simplify_log10 (gfc_expr
*x
)
4115 if (x
->expr_type
!= EXPR_CONSTANT
)
4118 if (mpfr_sgn (x
->value
.real
) <= 0)
4120 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4121 "to zero", &x
->where
);
4122 return &gfc_bad_expr
;
4125 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4126 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4128 return range_check (result
, "LOG10");
4133 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
4137 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
4139 return &gfc_bad_expr
;
4141 if (e
->expr_type
!= EXPR_CONSTANT
)
4144 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
4149 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
4152 int row
, result_rows
, col
, result_columns
;
4153 int stride_a
, offset_a
, stride_b
, offset_b
;
4155 if (!is_constant_array_expr (matrix_a
)
4156 || !is_constant_array_expr (matrix_b
))
4159 gcc_assert (gfc_compare_types (&matrix_a
->ts
, &matrix_b
->ts
));
4160 result
= gfc_get_array_expr (matrix_a
->ts
.type
,
4164 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
4167 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4169 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4172 result
->shape
= gfc_get_shape (result
->rank
);
4173 mpz_init_set_si (result
->shape
[0], result_columns
);
4175 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
4177 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4179 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4183 result
->shape
= gfc_get_shape (result
->rank
);
4184 mpz_init_set_si (result
->shape
[0], result_rows
);
4186 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
4188 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4189 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4190 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4191 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4194 result
->shape
= gfc_get_shape (result
->rank
);
4195 mpz_init_set_si (result
->shape
[0], result_rows
);
4196 mpz_init_set_si (result
->shape
[1], result_columns
);
4201 offset_a
= offset_b
= 0;
4202 for (col
= 0; col
< result_columns
; ++col
)
4206 for (row
= 0; row
< result_rows
; ++row
)
4208 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
4209 matrix_b
, 1, offset_b
, false);
4210 gfc_constructor_append_expr (&result
->value
.constructor
,
4216 offset_b
+= stride_b
;
4224 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
4230 if (i
->expr_type
!= EXPR_CONSTANT
)
4233 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
4235 return &gfc_bad_expr
;
4236 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4238 s
= gfc_extract_int (i
, &arg
);
4241 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4243 /* MASKR(n) = 2^n - 1 */
4244 mpz_set_ui (result
->value
.integer
, 1);
4245 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4246 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4248 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4255 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4262 if (i
->expr_type
!= EXPR_CONSTANT
)
4265 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4267 return &gfc_bad_expr
;
4268 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4270 s
= gfc_extract_int (i
, &arg
);
4273 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4275 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4276 mpz_init_set_ui (z
, 1);
4277 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4278 mpz_set_ui (result
->value
.integer
, 1);
4279 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4280 gfc_integer_kinds
[k
].bit_size
- arg
);
4281 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4284 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4291 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4294 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4296 if (mask
->expr_type
== EXPR_CONSTANT
)
4297 return gfc_get_parentheses (gfc_copy_expr (mask
->value
.logical
4298 ? tsource
: fsource
));
4300 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4301 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4304 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4306 if (tsource
->ts
.type
== BT_DERIVED
)
4307 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4308 else if (tsource
->ts
.type
== BT_CHARACTER
)
4309 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4311 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4312 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4313 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4317 if (mask_ctor
->expr
->value
.logical
)
4318 gfc_constructor_append_expr (&result
->value
.constructor
,
4319 gfc_copy_expr (tsource_ctor
->expr
),
4322 gfc_constructor_append_expr (&result
->value
.constructor
,
4323 gfc_copy_expr (fsource_ctor
->expr
),
4325 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4326 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4327 mask_ctor
= gfc_constructor_next (mask_ctor
);
4330 result
->shape
= gfc_get_shape (1);
4331 gfc_array_size (result
, &result
->shape
[0]);
4338 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4340 mpz_t arg1
, arg2
, mask
;
4343 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4344 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4347 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4349 /* Convert all argument to unsigned. */
4350 mpz_init_set (arg1
, i
->value
.integer
);
4351 mpz_init_set (arg2
, j
->value
.integer
);
4352 mpz_init_set (mask
, mask_expr
->value
.integer
);
4354 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4355 mpz_and (arg1
, arg1
, mask
);
4356 mpz_com (mask
, mask
);
4357 mpz_and (arg2
, arg2
, mask
);
4358 mpz_ior (result
->value
.integer
, arg1
, arg2
);
4368 /* Selects between current value and extremum for simplify_min_max
4369 and simplify_minval_maxval. */
4371 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
)
4373 switch (arg
->ts
.type
)
4376 if (mpz_cmp (arg
->value
.integer
,
4377 extremum
->value
.integer
) * sign
> 0)
4378 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
4382 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4384 mpfr_max (extremum
->value
.real
, extremum
->value
.real
,
4385 arg
->value
.real
, GFC_RND_MODE
);
4387 mpfr_min (extremum
->value
.real
, extremum
->value
.real
,
4388 arg
->value
.real
, GFC_RND_MODE
);
4392 #define LENGTH(x) ((x)->value.character.length)
4393 #define STRING(x) ((x)->value.character.string)
4394 if (LENGTH (extremum
) < LENGTH(arg
))
4396 gfc_char_t
*tmp
= STRING(extremum
);
4398 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
4399 memcpy (STRING(extremum
), tmp
,
4400 LENGTH(extremum
) * sizeof (gfc_char_t
));
4401 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
4402 LENGTH(arg
) - LENGTH(extremum
));
4403 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
4404 LENGTH(extremum
) = LENGTH(arg
);
4408 if (gfc_compare_string (arg
, extremum
) * sign
> 0)
4410 free (STRING(extremum
));
4411 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
4412 memcpy (STRING(extremum
), STRING(arg
),
4413 LENGTH(arg
) * sizeof (gfc_char_t
));
4414 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
4415 LENGTH(extremum
) - LENGTH(arg
));
4416 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
4423 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4428 /* This function is special since MAX() can take any number of
4429 arguments. The simplified expression is a rewritten version of the
4430 argument list containing at most one constant element. Other
4431 constant elements are deleted. Because the argument list has
4432 already been checked, this function always succeeds. sign is 1 for
4433 MAX(), -1 for MIN(). */
4436 simplify_min_max (gfc_expr
*expr
, int sign
)
4438 gfc_actual_arglist
*arg
, *last
, *extremum
;
4439 gfc_intrinsic_sym
* specific
;
4443 specific
= expr
->value
.function
.isym
;
4445 arg
= expr
->value
.function
.actual
;
4447 for (; arg
; last
= arg
, arg
= arg
->next
)
4449 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
4452 if (extremum
== NULL
)
4458 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
4460 /* Delete the extra constant argument. */
4461 last
->next
= arg
->next
;
4464 gfc_free_actual_arglist (arg
);
4468 /* If there is one value left, replace the function call with the
4470 if (expr
->value
.function
.actual
->next
!= NULL
)
4473 /* Convert to the correct type and kind. */
4474 if (expr
->ts
.type
!= BT_UNKNOWN
)
4475 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4476 expr
->ts
.type
, expr
->ts
.kind
);
4478 if (specific
->ts
.type
!= BT_UNKNOWN
)
4479 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4480 specific
->ts
.type
, specific
->ts
.kind
);
4482 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
4487 gfc_simplify_min (gfc_expr
*e
)
4489 return simplify_min_max (e
, -1);
4494 gfc_simplify_max (gfc_expr
*e
)
4496 return simplify_min_max (e
, 1);
4500 /* This is a simplified version of simplify_min_max to provide
4501 simplification of minval and maxval for a vector. */
4504 simplify_minval_maxval (gfc_expr
*expr
, int sign
)
4506 gfc_constructor
*c
, *extremum
;
4507 gfc_intrinsic_sym
* specific
;
4510 specific
= expr
->value
.function
.isym
;
4512 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4513 c
; c
= gfc_constructor_next (c
))
4515 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4518 if (extremum
== NULL
)
4524 min_max_choose (c
->expr
, extremum
->expr
, sign
);
4527 if (extremum
== NULL
)
4530 /* Convert to the correct type and kind. */
4531 if (expr
->ts
.type
!= BT_UNKNOWN
)
4532 return gfc_convert_constant (extremum
->expr
,
4533 expr
->ts
.type
, expr
->ts
.kind
);
4535 if (specific
->ts
.type
!= BT_UNKNOWN
)
4536 return gfc_convert_constant (extremum
->expr
,
4537 specific
->ts
.type
, specific
->ts
.kind
);
4539 return gfc_copy_expr (extremum
->expr
);
4544 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4546 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4549 return simplify_minval_maxval (array
, -1);
4554 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4556 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4559 return simplify_minval_maxval (array
, 1);
4564 gfc_simplify_maxexponent (gfc_expr
*x
)
4566 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4567 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4568 gfc_real_kinds
[i
].max_exponent
);
4573 gfc_simplify_minexponent (gfc_expr
*x
)
4575 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4576 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4577 gfc_real_kinds
[i
].min_exponent
);
4582 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
4587 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4590 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4591 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4596 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4598 /* Result is processor-dependent. */
4599 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
4600 gfc_free_expr (result
);
4601 return &gfc_bad_expr
;
4603 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4607 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4609 /* Result is processor-dependent. */
4610 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
4611 gfc_free_expr (result
);
4612 return &gfc_bad_expr
;
4615 gfc_set_model_kind (kind
);
4616 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4621 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4624 return range_check (result
, "MOD");
4629 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
4634 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4637 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4638 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4643 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4645 /* Result is processor-dependent. This processor just opts
4646 to not handle it at all. */
4647 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
4648 gfc_free_expr (result
);
4649 return &gfc_bad_expr
;
4651 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4656 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4658 /* Result is processor-dependent. */
4659 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
4660 gfc_free_expr (result
);
4661 return &gfc_bad_expr
;
4664 gfc_set_model_kind (kind
);
4665 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4667 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
4669 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
4670 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
4674 mpfr_copysign (result
->value
.real
, result
->value
.real
,
4675 p
->value
.real
, GFC_RND_MODE
);
4679 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4682 return range_check (result
, "MODULO");
4687 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
4690 mp_exp_t emin
, emax
;
4693 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
4696 result
= gfc_copy_expr (x
);
4698 /* Save current values of emin and emax. */
4699 emin
= mpfr_get_emin ();
4700 emax
= mpfr_get_emax ();
4702 /* Set emin and emax for the current model number. */
4703 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
4704 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
4705 mpfr_get_prec(result
->value
.real
) + 1);
4706 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
4707 mpfr_check_range (result
->value
.real
, 0, GMP_RNDU
);
4709 if (mpfr_sgn (s
->value
.real
) > 0)
4711 mpfr_nextabove (result
->value
.real
);
4712 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
4716 mpfr_nextbelow (result
->value
.real
);
4717 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
4720 mpfr_set_emin (emin
);
4721 mpfr_set_emax (emax
);
4723 /* Only NaN can occur. Do not use range check as it gives an
4724 error for denormal numbers. */
4725 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
4727 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
4728 gfc_free_expr (result
);
4729 return &gfc_bad_expr
;
4737 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
4739 gfc_expr
*itrunc
, *result
;
4742 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
4744 return &gfc_bad_expr
;
4746 if (e
->expr_type
!= EXPR_CONSTANT
)
4749 itrunc
= gfc_copy_expr (e
);
4750 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
4752 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
4753 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
4755 gfc_free_expr (itrunc
);
4757 return range_check (result
, name
);
4762 gfc_simplify_new_line (gfc_expr
*e
)
4766 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
4767 result
->value
.character
.string
[0] = '\n';
4774 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
4776 return simplify_nint ("NINT", e
, k
);
4781 gfc_simplify_idnint (gfc_expr
*e
)
4783 return simplify_nint ("IDNINT", e
, NULL
);
4788 add_squared (gfc_expr
*result
, gfc_expr
*e
)
4792 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4793 gcc_assert (result
->ts
.type
== BT_REAL
4794 && result
->expr_type
== EXPR_CONSTANT
);
4796 gfc_set_model_kind (result
->ts
.kind
);
4798 mpfr_pow_ui (tmp
, e
->value
.real
, 2, GFC_RND_MODE
);
4799 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
4808 do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
4810 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4811 gcc_assert (result
->ts
.type
== BT_REAL
4812 && result
->expr_type
== EXPR_CONSTANT
);
4814 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
4815 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4821 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
4825 if (!is_constant_array_expr (e
)
4826 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
4829 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4830 init_result_expr (result
, 0, NULL
);
4832 if (!dim
|| e
->rank
== 1)
4834 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
4836 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4839 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
4840 add_squared
, &do_sqrt
);
4847 gfc_simplify_not (gfc_expr
*e
)
4851 if (e
->expr_type
!= EXPR_CONSTANT
)
4854 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4855 mpz_com (result
->value
.integer
, e
->value
.integer
);
4857 return range_check (result
, "NOT");
4862 gfc_simplify_null (gfc_expr
*mold
)
4868 result
= gfc_copy_expr (mold
);
4869 result
->expr_type
= EXPR_NULL
;
4872 result
= gfc_get_null_expr (NULL
);
4879 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
4883 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4885 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4886 return &gfc_bad_expr
;
4889 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
4892 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
4895 /* FIXME: gfc_current_locus is wrong. */
4896 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
4897 &gfc_current_locus
);
4899 if (failed
&& failed
->value
.logical
!= 0)
4900 mpz_set_si (result
->value
.integer
, 0);
4902 mpz_set_si (result
->value
.integer
, 1);
4909 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
4914 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4917 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4922 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
4923 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4924 return range_check (result
, "OR");
4927 return gfc_get_logical_expr (kind
, &x
->where
,
4928 x
->value
.logical
|| y
->value
.logical
);
4936 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4939 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
4941 if (!is_constant_array_expr (array
)
4942 || !is_constant_array_expr (vector
)
4943 || (!gfc_is_constant_expr (mask
)
4944 && !is_constant_array_expr (mask
)))
4947 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
4948 if (array
->ts
.type
== BT_DERIVED
)
4949 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
4951 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
4952 vector_ctor
= vector
4953 ? gfc_constructor_first (vector
->value
.constructor
)
4956 if (mask
->expr_type
== EXPR_CONSTANT
4957 && mask
->value
.logical
)
4959 /* Copy all elements of ARRAY to RESULT. */
4962 gfc_constructor_append_expr (&result
->value
.constructor
,
4963 gfc_copy_expr (array_ctor
->expr
),
4966 array_ctor
= gfc_constructor_next (array_ctor
);
4967 vector_ctor
= gfc_constructor_next (vector_ctor
);
4970 else if (mask
->expr_type
== EXPR_ARRAY
)
4972 /* Copy only those elements of ARRAY to RESULT whose
4973 MASK equals .TRUE.. */
4974 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4977 if (mask_ctor
->expr
->value
.logical
)
4979 gfc_constructor_append_expr (&result
->value
.constructor
,
4980 gfc_copy_expr (array_ctor
->expr
),
4982 vector_ctor
= gfc_constructor_next (vector_ctor
);
4985 array_ctor
= gfc_constructor_next (array_ctor
);
4986 mask_ctor
= gfc_constructor_next (mask_ctor
);
4990 /* Append any left-over elements from VECTOR to RESULT. */
4993 gfc_constructor_append_expr (&result
->value
.constructor
,
4994 gfc_copy_expr (vector_ctor
->expr
),
4996 vector_ctor
= gfc_constructor_next (vector_ctor
);
4999 result
->shape
= gfc_get_shape (1);
5000 gfc_array_size (result
, &result
->shape
[0]);
5002 if (array
->ts
.type
== BT_CHARACTER
)
5003 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
5010 do_xor (gfc_expr
*result
, gfc_expr
*e
)
5012 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
5013 gcc_assert (result
->ts
.type
== BT_LOGICAL
5014 && result
->expr_type
== EXPR_CONSTANT
);
5016 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
5023 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
5025 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
5030 gfc_simplify_popcnt (gfc_expr
*e
)
5035 if (e
->expr_type
!= EXPR_CONSTANT
)
5038 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5040 /* Convert argument to unsigned, then count the '1' bits. */
5041 mpz_init_set (x
, e
->value
.integer
);
5042 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
5043 res
= mpz_popcount (x
);
5046 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
5051 gfc_simplify_poppar (gfc_expr
*e
)
5057 if (e
->expr_type
!= EXPR_CONSTANT
)
5060 popcnt
= gfc_simplify_popcnt (e
);
5061 gcc_assert (popcnt
);
5063 s
= gfc_extract_int (popcnt
, &i
);
5066 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
5071 gfc_simplify_precision (gfc_expr
*e
)
5073 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5074 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
5075 gfc_real_kinds
[i
].precision
);
5080 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
5082 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
5087 gfc_simplify_radix (gfc_expr
*e
)
5090 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5095 i
= gfc_integer_kinds
[i
].radix
;
5099 i
= gfc_real_kinds
[i
].radix
;
5106 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
5111 gfc_simplify_range (gfc_expr
*e
)
5114 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5119 i
= gfc_integer_kinds
[i
].range
;
5124 i
= gfc_real_kinds
[i
].range
;
5131 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
5136 gfc_simplify_rank (gfc_expr
*e
)
5142 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
5147 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
5149 gfc_expr
*result
= NULL
;
5152 if (e
->ts
.type
== BT_COMPLEX
)
5153 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
5155 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
5158 return &gfc_bad_expr
;
5160 if (e
->expr_type
!= EXPR_CONSTANT
)
5163 if (convert_boz (e
, kind
) == &gfc_bad_expr
)
5164 return &gfc_bad_expr
;
5166 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
5167 if (result
== &gfc_bad_expr
)
5168 return &gfc_bad_expr
;
5170 return range_check (result
, "REAL");
5175 gfc_simplify_realpart (gfc_expr
*e
)
5179 if (e
->expr_type
!= EXPR_CONSTANT
)
5182 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
5183 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
5185 return range_check (result
, "REALPART");
5189 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
5192 int i
, j
, len
, ncop
, nlen
;
5194 bool have_length
= false;
5196 /* If NCOPIES isn't a constant, there's nothing we can do. */
5197 if (n
->expr_type
!= EXPR_CONSTANT
)
5200 /* If NCOPIES is negative, it's an error. */
5201 if (mpz_sgn (n
->value
.integer
) < 0)
5203 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
5205 return &gfc_bad_expr
;
5208 /* If we don't know the character length, we can do no more. */
5209 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
5210 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5212 len
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
5215 else if (e
->expr_type
== EXPR_CONSTANT
5216 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
5218 len
= e
->value
.character
.length
;
5223 /* If the source length is 0, any value of NCOPIES is valid
5224 and everything behaves as if NCOPIES == 0. */
5227 mpz_set_ui (ncopies
, 0);
5229 mpz_set (ncopies
, n
->value
.integer
);
5231 /* Check that NCOPIES isn't too large. */
5237 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
5239 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5243 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
5244 e
->ts
.u
.cl
->length
->value
.integer
);
5248 mpz_init_set_si (mlen
, len
);
5249 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
5253 /* The check itself. */
5254 if (mpz_cmp (ncopies
, max
) > 0)
5257 mpz_clear (ncopies
);
5258 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
5260 return &gfc_bad_expr
;
5265 mpz_clear (ncopies
);
5267 /* For further simplification, we need the character string to be
5269 if (e
->expr_type
!= EXPR_CONSTANT
)
5273 (e
->ts
.u
.cl
->length
&&
5274 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
) != 0))
5276 const char *res
= gfc_extract_int (n
, &ncop
);
5277 gcc_assert (res
== NULL
);
5283 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
5285 len
= e
->value
.character
.length
;
5288 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
5289 for (i
= 0; i
< ncop
; i
++)
5290 for (j
= 0; j
< len
; j
++)
5291 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
5293 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
5298 /* This one is a bear, but mainly has to do with shuffling elements. */
5301 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
5302 gfc_expr
*pad
, gfc_expr
*order_exp
)
5304 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
5305 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
5309 gfc_expr
*e
, *result
;
5311 /* Check that argument expression types are OK. */
5312 if (!is_constant_array_expr (source
)
5313 || !is_constant_array_expr (shape_exp
)
5314 || !is_constant_array_expr (pad
)
5315 || !is_constant_array_expr (order_exp
))
5318 if (source
->shape
== NULL
)
5321 /* Proceed with simplification, unpacking the array. */
5328 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
5332 gfc_extract_int (e
, &shape
[rank
]);
5334 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
5335 gcc_assert (shape
[rank
] >= 0);
5340 gcc_assert (rank
> 0);
5342 /* Now unpack the order array if present. */
5343 if (order_exp
== NULL
)
5345 for (i
= 0; i
< rank
; i
++)
5350 for (i
= 0; i
< rank
; i
++)
5353 for (i
= 0; i
< rank
; i
++)
5355 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
5358 gfc_extract_int (e
, &order
[i
]);
5360 gcc_assert (order
[i
] >= 1 && order
[i
] <= rank
);
5362 gcc_assert (x
[order
[i
]] == 0);
5367 /* Count the elements in the source and padding arrays. */
5372 gfc_array_size (pad
, &size
);
5373 npad
= mpz_get_ui (size
);
5377 gfc_array_size (source
, &size
);
5378 nsource
= mpz_get_ui (size
);
5381 /* If it weren't for that pesky permutation we could just loop
5382 through the source and round out any shortage with pad elements.
5383 But no, someone just had to have the compiler do something the
5384 user should be doing. */
5386 for (i
= 0; i
< rank
; i
++)
5389 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
5391 if (source
->ts
.type
== BT_DERIVED
)
5392 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
5393 result
->rank
= rank
;
5394 result
->shape
= gfc_get_shape (rank
);
5395 for (i
= 0; i
< rank
; i
++)
5396 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
5398 while (nsource
> 0 || npad
> 0)
5400 /* Figure out which element to extract. */
5401 mpz_set_ui (index
, 0);
5403 for (i
= rank
- 1; i
>= 0; i
--)
5405 mpz_add_ui (index
, index
, x
[order
[i
]]);
5407 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
5410 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
5411 gfc_internal_error ("Reshaped array too large at %C");
5413 j
= mpz_get_ui (index
);
5416 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
5426 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
5430 gfc_constructor_append_expr (&result
->value
.constructor
,
5431 gfc_copy_expr (e
), &e
->where
);
5433 /* Calculate the next element. */
5437 if (++x
[i
] < shape
[i
])
5453 gfc_simplify_rrspacing (gfc_expr
*x
)
5459 if (x
->expr_type
!= EXPR_CONSTANT
)
5462 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5464 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5466 /* RRSPACING(+/- 0.0) = 0.0 */
5467 if (mpfr_zero_p (x
->value
.real
))
5469 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5473 /* RRSPACING(inf) = NaN */
5474 if (mpfr_inf_p (x
->value
.real
))
5476 mpfr_set_nan (result
->value
.real
);
5480 /* RRSPACING(NaN) = same NaN */
5481 if (mpfr_nan_p (x
->value
.real
))
5483 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5487 /* | x * 2**(-e) | * 2**p. */
5488 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5489 e
= - (long int) mpfr_get_exp (x
->value
.real
);
5490 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
5492 p
= (long int) gfc_real_kinds
[i
].digits
;
5493 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
5495 return range_check (result
, "RRSPACING");
5500 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
5502 int k
, neg_flag
, power
, exp_range
;
5503 mpfr_t scale
, radix
;
5506 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5509 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5511 if (mpfr_zero_p (x
->value
.real
))
5513 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5517 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5519 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
5521 /* This check filters out values of i that would overflow an int. */
5522 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
5523 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
5525 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
5526 gfc_free_expr (result
);
5527 return &gfc_bad_expr
;
5530 /* Compute scale = radix ** power. */
5531 power
= mpz_get_si (i
->value
.integer
);
5541 gfc_set_model_kind (x
->ts
.kind
);
5544 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
5545 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
5548 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5550 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5552 mpfr_clears (scale
, radix
, NULL
);
5554 return range_check (result
, "SCALE");
5558 /* Variants of strspn and strcspn that operate on wide characters. */
5561 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5564 const gfc_char_t
*c
;
5568 for (c
= s2
; *c
; c
++)
5582 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5585 const gfc_char_t
*c
;
5589 for (c
= s2
; *c
; c
++)
5604 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
5609 size_t indx
, len
, lenc
;
5610 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
5613 return &gfc_bad_expr
;
5615 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
5616 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
5619 if (b
!= NULL
&& b
->value
.logical
!= 0)
5624 len
= e
->value
.character
.length
;
5625 lenc
= c
->value
.character
.length
;
5627 if (len
== 0 || lenc
== 0)
5635 indx
= wide_strcspn (e
->value
.character
.string
,
5636 c
->value
.character
.string
) + 1;
5643 for (indx
= len
; indx
> 0; indx
--)
5645 for (i
= 0; i
< lenc
; i
++)
5647 if (c
->value
.character
.string
[i
]
5648 == e
->value
.character
.string
[indx
- 1])
5657 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
5658 return range_check (result
, "SCAN");
5663 gfc_simplify_selected_char_kind (gfc_expr
*e
)
5667 if (e
->expr_type
!= EXPR_CONSTANT
)
5670 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
5671 || gfc_compare_with_Cstring (e
, "default", false) == 0)
5673 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
5678 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5683 gfc_simplify_selected_int_kind (gfc_expr
*e
)
5687 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
) != NULL
)
5692 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
5693 if (gfc_integer_kinds
[i
].range
>= range
5694 && gfc_integer_kinds
[i
].kind
< kind
)
5695 kind
= gfc_integer_kinds
[i
].kind
;
5697 if (kind
== INT_MAX
)
5700 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5705 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
5707 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
5709 locus
*loc
= &gfc_current_locus
;
5715 if (p
->expr_type
!= EXPR_CONSTANT
5716 || gfc_extract_int (p
, &precision
) != NULL
)
5725 if (q
->expr_type
!= EXPR_CONSTANT
5726 || gfc_extract_int (q
, &range
) != NULL
)
5737 if (rdx
->expr_type
!= EXPR_CONSTANT
5738 || gfc_extract_int (rdx
, &radix
) != NULL
)
5746 found_precision
= 0;
5750 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5752 if (gfc_real_kinds
[i
].precision
>= precision
)
5753 found_precision
= 1;
5755 if (gfc_real_kinds
[i
].range
>= range
)
5758 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5761 if (gfc_real_kinds
[i
].precision
>= precision
5762 && gfc_real_kinds
[i
].range
>= range
5763 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5764 && gfc_real_kinds
[i
].kind
< kind
)
5765 kind
= gfc_real_kinds
[i
].kind
;
5768 if (kind
== INT_MAX
)
5770 if (found_radix
&& found_range
&& !found_precision
)
5772 else if (found_radix
&& found_precision
&& !found_range
)
5774 else if (found_radix
&& !found_precision
&& !found_range
)
5776 else if (found_radix
)
5782 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
5787 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5790 mpfr_t exp
, absv
, log2
, pow2
, frac
;
5793 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5796 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5798 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
5799 SET_EXPONENT (NaN) = same NaN */
5800 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
5802 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5806 /* SET_EXPONENT (inf) = NaN */
5807 if (mpfr_inf_p (x
->value
.real
))
5809 mpfr_set_nan (result
->value
.real
);
5813 gfc_set_model_kind (x
->ts
.kind
);
5820 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
5821 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
5823 mpfr_trunc (log2
, log2
);
5824 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
5826 /* Old exponent value, and fraction. */
5827 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
5829 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
5832 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
5833 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
5835 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
5837 return range_check (result
, "SET_EXPONENT");
5842 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
5844 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5845 gfc_expr
*result
, *e
, *f
;
5849 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
5851 if (source
->rank
== -1)
5854 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
5856 if (source
->rank
== 0)
5859 if (source
->expr_type
== EXPR_VARIABLE
)
5861 ar
= gfc_find_array_ref (source
);
5862 t
= gfc_array_ref_shape (ar
, shape
);
5864 else if (source
->shape
)
5867 for (n
= 0; n
< source
->rank
; n
++)
5869 mpz_init (shape
[n
]);
5870 mpz_set (shape
[n
], source
->shape
[n
]);
5876 for (n
= 0; n
< source
->rank
; n
++)
5878 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
5881 mpz_set (e
->value
.integer
, shape
[n
]);
5884 mpz_set_ui (e
->value
.integer
, n
+ 1);
5886 f
= simplify_size (source
, e
, k
);
5890 gfc_free_expr (result
);
5897 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
5899 gfc_free_expr (result
);
5901 gfc_clear_shape (shape
, source
->rank
);
5902 return &gfc_bad_expr
;
5905 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
5909 gfc_clear_shape (shape
, source
->rank
);
5916 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
5919 gfc_expr
*return_value
;
5922 /* For unary operations, the size of the result is given by the size
5923 of the operand. For binary ones, it's the size of the first operand
5924 unless it is scalar, then it is the size of the second. */
5925 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
5927 gfc_expr
* replacement
;
5928 gfc_expr
* simplified
;
5930 switch (array
->value
.op
.op
)
5932 /* Unary operations. */
5934 case INTRINSIC_UPLUS
:
5935 case INTRINSIC_UMINUS
:
5936 case INTRINSIC_PARENTHESES
:
5937 replacement
= array
->value
.op
.op1
;
5940 /* Binary operations. If any one of the operands is scalar, take
5941 the other one's size. If both of them are arrays, it does not
5942 matter -- try to find one with known shape, if possible. */
5944 if (array
->value
.op
.op1
->rank
== 0)
5945 replacement
= array
->value
.op
.op2
;
5946 else if (array
->value
.op
.op2
->rank
== 0)
5947 replacement
= array
->value
.op
.op1
;
5950 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
5954 replacement
= array
->value
.op
.op2
;
5959 /* Try to reduce it directly if possible. */
5960 simplified
= simplify_size (replacement
, dim
, k
);
5962 /* Otherwise, we build a new SIZE call. This is hopefully at least
5963 simpler than the original one. */
5966 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
5967 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
5968 GFC_ISYM_SIZE
, "size",
5970 gfc_copy_expr (replacement
),
5971 gfc_copy_expr (dim
),
5979 if (!gfc_array_size (array
, &size
))
5984 if (dim
->expr_type
!= EXPR_CONSTANT
)
5987 d
= mpz_get_ui (dim
->value
.integer
) - 1;
5988 if (!gfc_array_dimen_size (array
, d
, &size
))
5992 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
5993 mpz_set (return_value
->value
.integer
, size
);
5996 return return_value
;
6001 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6004 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
6007 return &gfc_bad_expr
;
6009 result
= simplify_size (array
, dim
, k
);
6010 if (result
== NULL
|| result
== &gfc_bad_expr
)
6013 return range_check (result
, "SIZE");
6017 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
6018 multiplied by the array size. */
6021 gfc_simplify_sizeof (gfc_expr
*x
)
6023 gfc_expr
*result
= NULL
;
6026 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
6029 if (x
->ts
.type
== BT_CHARACTER
6030 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
6031 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
6034 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
6035 && !gfc_array_size (x
, &array_size
))
6038 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
6040 mpz_set_si (result
->value
.integer
, gfc_target_expr_size (x
));
6046 /* STORAGE_SIZE returns the size in bits of a single array element. */
6049 gfc_simplify_storage_size (gfc_expr
*x
,
6052 gfc_expr
*result
= NULL
;
6055 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
6058 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
6059 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
6060 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
6063 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
6065 return &gfc_bad_expr
;
6067 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
6069 mpz_set_si (result
->value
.integer
, gfc_element_size (x
));
6070 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
6072 return range_check (result
, "STORAGE_SIZE");
6077 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
6081 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6084 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6089 mpz_abs (result
->value
.integer
, x
->value
.integer
);
6090 if (mpz_sgn (y
->value
.integer
) < 0)
6091 mpz_neg (result
->value
.integer
, result
->value
.integer
);
6096 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
6099 mpfr_setsign (result
->value
.real
, x
->value
.real
,
6100 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
6104 gfc_internal_error ("Bad type in gfc_simplify_sign");
6112 gfc_simplify_sin (gfc_expr
*x
)
6116 if (x
->expr_type
!= EXPR_CONSTANT
)
6119 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6124 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6128 gfc_set_model (x
->value
.real
);
6129 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6133 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
6136 return range_check (result
, "SIN");
6141 gfc_simplify_sinh (gfc_expr
*x
)
6145 if (x
->expr_type
!= EXPR_CONSTANT
)
6148 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6153 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6157 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6164 return range_check (result
, "SINH");
6168 /* The argument is always a double precision real that is converted to
6169 single precision. TODO: Rounding! */
6172 gfc_simplify_sngl (gfc_expr
*a
)
6176 if (a
->expr_type
!= EXPR_CONSTANT
)
6179 result
= gfc_real2real (a
, gfc_default_real_kind
);
6180 return range_check (result
, "SNGL");
6185 gfc_simplify_spacing (gfc_expr
*x
)
6191 if (x
->expr_type
!= EXPR_CONSTANT
)
6194 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
6195 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
6197 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
6198 if (mpfr_zero_p (x
->value
.real
))
6200 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6204 /* SPACING(inf) = NaN */
6205 if (mpfr_inf_p (x
->value
.real
))
6207 mpfr_set_nan (result
->value
.real
);
6211 /* SPACING(NaN) = same NaN */
6212 if (mpfr_nan_p (x
->value
.real
))
6214 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6218 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
6219 are the radix, exponent of x, and precision. This excludes the
6220 possibility of subnormal numbers. Fortran 2003 states the result is
6221 b**max(e - p, emin - 1). */
6223 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
6224 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
6225 en
= en
> ep
? en
: ep
;
6227 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
6228 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
6230 return range_check (result
, "SPACING");
6235 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
6237 gfc_expr
*result
= NULL
;
6238 int nelem
, i
, j
, dim
, ncopies
;
6241 if ((!gfc_is_constant_expr (source
)
6242 && !is_constant_array_expr (source
))
6243 || !gfc_is_constant_expr (dim_expr
)
6244 || !gfc_is_constant_expr (ncopies_expr
))
6247 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
6248 gfc_extract_int (dim_expr
, &dim
);
6249 dim
-= 1; /* zero-base DIM */
6251 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
6252 gfc_extract_int (ncopies_expr
, &ncopies
);
6253 ncopies
= MAX (ncopies
, 0);
6255 /* Do not allow the array size to exceed the limit for an array
6257 if (source
->expr_type
== EXPR_ARRAY
)
6259 if (!gfc_array_size (source
, &size
))
6260 gfc_internal_error ("Failure getting length of a constant array.");
6263 mpz_init_set_ui (size
, 1);
6265 nelem
= mpz_get_si (size
) * ncopies
;
6266 if (nelem
> flag_max_array_constructor
)
6268 if (gfc_current_ns
->sym_root
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
6270 gfc_error ("The number of elements (%d) in the array constructor "
6271 "at %L requires an increase of the allowed %d upper "
6272 "limit. See %<-fmax-array-constructor%> option.",
6273 nelem
, &source
->where
, flag_max_array_constructor
);
6274 return &gfc_bad_expr
;
6280 if (source
->expr_type
== EXPR_CONSTANT
)
6282 gcc_assert (dim
== 0);
6284 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6286 if (source
->ts
.type
== BT_DERIVED
)
6287 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6289 result
->shape
= gfc_get_shape (result
->rank
);
6290 mpz_init_set_si (result
->shape
[0], ncopies
);
6292 for (i
= 0; i
< ncopies
; ++i
)
6293 gfc_constructor_append_expr (&result
->value
.constructor
,
6294 gfc_copy_expr (source
), NULL
);
6296 else if (source
->expr_type
== EXPR_ARRAY
)
6298 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
6299 gfc_constructor
*source_ctor
;
6301 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
6302 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
6304 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6306 if (source
->ts
.type
== BT_DERIVED
)
6307 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6308 result
->rank
= source
->rank
+ 1;
6309 result
->shape
= gfc_get_shape (result
->rank
);
6311 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
6314 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
6316 mpz_init_set_si (result
->shape
[i
], ncopies
);
6318 extent
[i
] = mpz_get_si (result
->shape
[i
]);
6319 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
6323 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
6324 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
6326 for (i
= 0; i
< ncopies
; ++i
)
6327 gfc_constructor_insert_expr (&result
->value
.constructor
,
6328 gfc_copy_expr (source_ctor
->expr
),
6329 NULL
, offset
+ i
* rstride
[dim
]);
6331 offset
+= (dim
== 0 ? ncopies
: 1);
6336 gfc_error ("Simplification of SPREAD at %C not yet implemented");
6337 return &gfc_bad_expr
;
6340 if (source
->ts
.type
== BT_CHARACTER
)
6341 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
6348 gfc_simplify_sqrt (gfc_expr
*e
)
6350 gfc_expr
*result
= NULL
;
6352 if (e
->expr_type
!= EXPR_CONSTANT
)
6358 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
6360 gfc_error ("Argument of SQRT at %L has a negative value",
6362 return &gfc_bad_expr
;
6364 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6365 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6369 gfc_set_model (e
->value
.real
);
6371 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6372 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
6376 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
6379 return range_check (result
, "SQRT");
6384 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6386 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
6391 gfc_simplify_cotan (gfc_expr
*x
)
6396 if (x
->expr_type
!= EXPR_CONSTANT
)
6399 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6404 mpfr_cot (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6408 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
6409 val
= &result
->value
.complex;
6410 mpc_init2 (swp
, mpfr_get_default_prec ());
6411 mpc_cos (swp
, x
->value
.complex, GFC_MPC_RND_MODE
);
6412 mpc_sin (*val
, x
->value
.complex, GFC_MPC_RND_MODE
);
6413 mpc_div (*val
, swp
, *val
, GFC_MPC_RND_MODE
);
6421 return range_check (result
, "COTAN");
6426 gfc_simplify_tan (gfc_expr
*x
)
6430 if (x
->expr_type
!= EXPR_CONSTANT
)
6433 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6438 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6442 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6449 return range_check (result
, "TAN");
6454 gfc_simplify_tanh (gfc_expr
*x
)
6458 if (x
->expr_type
!= EXPR_CONSTANT
)
6461 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6466 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6470 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6477 return range_check (result
, "TANH");
6482 gfc_simplify_tiny (gfc_expr
*e
)
6487 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
6489 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6490 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6497 gfc_simplify_trailz (gfc_expr
*e
)
6499 unsigned long tz
, bs
;
6502 if (e
->expr_type
!= EXPR_CONSTANT
)
6505 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6506 bs
= gfc_integer_kinds
[i
].bit_size
;
6507 tz
= mpz_scan1 (e
->value
.integer
, 0);
6509 return gfc_get_int_expr (gfc_default_integer_kind
,
6510 &e
->where
, MIN (tz
, bs
));
6515 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6518 gfc_expr
*mold_element
;
6523 unsigned char *buffer
;
6524 size_t result_length
;
6527 if (!gfc_is_constant_expr (source
)
6528 || (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
6529 || !gfc_is_constant_expr (size
))
6532 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6533 &result_size
, &result_length
))
6536 /* Calculate the size of the source. */
6537 if (source
->expr_type
== EXPR_ARRAY
6538 && !gfc_array_size (source
, &tmp
))
6539 gfc_internal_error ("Failure getting length of a constant array.");
6541 /* Create an empty new expression with the appropriate characteristics. */
6542 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
6544 result
->ts
= mold
->ts
;
6546 mold_element
= mold
->expr_type
== EXPR_ARRAY
6547 ? gfc_constructor_first (mold
->value
.constructor
)->expr
6550 /* Set result character length, if needed. Note that this needs to be
6551 set even for array expressions, in order to pass this information into
6552 gfc_target_interpret_expr. */
6553 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
6554 result
->value
.character
.length
= mold_element
->value
.character
.length
;
6556 /* Set the number of elements in the result, and determine its size. */
6558 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
6560 result
->expr_type
= EXPR_ARRAY
;
6562 result
->shape
= gfc_get_shape (1);
6563 mpz_init_set_ui (result
->shape
[0], result_length
);
6568 /* Allocate the buffer to store the binary version of the source. */
6569 buffer_size
= MAX (source_size
, result_size
);
6570 buffer
= (unsigned char*)alloca (buffer_size
);
6571 memset (buffer
, 0, buffer_size
);
6573 /* Now write source to the buffer. */
6574 gfc_target_encode_expr (source
, buffer
, buffer_size
);
6576 /* And read the buffer back into the new expression. */
6577 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
6584 gfc_simplify_transpose (gfc_expr
*matrix
)
6586 int row
, matrix_rows
, col
, matrix_cols
;
6589 if (!is_constant_array_expr (matrix
))
6592 gcc_assert (matrix
->rank
== 2);
6594 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
6597 result
->shape
= gfc_get_shape (result
->rank
);
6598 mpz_set (result
->shape
[0], matrix
->shape
[1]);
6599 mpz_set (result
->shape
[1], matrix
->shape
[0]);
6601 if (matrix
->ts
.type
== BT_CHARACTER
)
6602 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
6603 else if (matrix
->ts
.type
== BT_DERIVED
)
6604 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
6606 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
6607 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
6608 for (row
= 0; row
< matrix_rows
; ++row
)
6609 for (col
= 0; col
< matrix_cols
; ++col
)
6611 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
6612 col
* matrix_rows
+ row
);
6613 gfc_constructor_insert_expr (&result
->value
.constructor
,
6614 gfc_copy_expr (e
), &matrix
->where
,
6615 row
* matrix_cols
+ col
);
6623 gfc_simplify_trim (gfc_expr
*e
)
6626 int count
, i
, len
, lentrim
;
6628 if (e
->expr_type
!= EXPR_CONSTANT
)
6631 len
= e
->value
.character
.length
;
6632 for (count
= 0, i
= 1; i
<= len
; ++i
)
6634 if (e
->value
.character
.string
[len
- i
] == ' ')
6640 lentrim
= len
- count
;
6642 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
6643 for (i
= 0; i
< lentrim
; i
++)
6644 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
6651 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
6656 gfc_constructor
*sub_cons
;
6660 if (!is_constant_array_expr (sub
))
6663 /* Follow any component references. */
6664 as
= coarray
->symtree
->n
.sym
->as
;
6665 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
6666 if (ref
->type
== REF_COMPONENT
)
6669 if (as
->type
== AS_DEFERRED
)
6672 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6673 the cosubscript addresses the first image. */
6675 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
6678 for (d
= 1; d
<= as
->corank
; d
++)
6683 gcc_assert (sub_cons
!= NULL
);
6685 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
6687 if (ca_bound
== NULL
)
6690 if (ca_bound
== &gfc_bad_expr
)
6693 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
6697 gfc_free_expr (ca_bound
);
6698 sub_cons
= gfc_constructor_next (sub_cons
);
6702 first_image
= false;
6706 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6707 "SUB has %ld and COARRAY lower bound is %ld)",
6709 mpz_get_si (sub_cons
->expr
->value
.integer
),
6710 mpz_get_si (ca_bound
->value
.integer
));
6711 gfc_free_expr (ca_bound
);
6712 return &gfc_bad_expr
;
6715 gfc_free_expr (ca_bound
);
6717 /* Check whether upperbound is valid for the multi-images case. */
6720 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
6722 if (ca_bound
== &gfc_bad_expr
)
6725 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
6726 && mpz_cmp (ca_bound
->value
.integer
,
6727 sub_cons
->expr
->value
.integer
) < 0)
6729 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6730 "SUB has %ld and COARRAY upper bound is %ld)",
6732 mpz_get_si (sub_cons
->expr
->value
.integer
),
6733 mpz_get_si (ca_bound
->value
.integer
));
6734 gfc_free_expr (ca_bound
);
6735 return &gfc_bad_expr
;
6739 gfc_free_expr (ca_bound
);
6742 sub_cons
= gfc_constructor_next (sub_cons
);
6745 gcc_assert (sub_cons
== NULL
);
6747 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
6750 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6751 &gfc_current_locus
);
6753 mpz_set_si (result
->value
.integer
, 1);
6755 mpz_set_si (result
->value
.integer
, 0);
6762 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
6763 gfc_expr
*distance ATTRIBUTE_UNUSED
)
6765 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6768 /* If no coarray argument has been passed or when the first argument
6769 is actually a distance argment. */
6770 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
6773 /* FIXME: gfc_current_locus is wrong. */
6774 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6775 &gfc_current_locus
);
6776 mpz_set_si (result
->value
.integer
, 1);
6780 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
6781 return simplify_cobound (coarray
, dim
, NULL
, 0);
6786 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6788 return simplify_bound (array
, dim
, kind
, 1);
6792 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6794 return simplify_cobound (array
, dim
, kind
, 1);
6799 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6801 gfc_expr
*result
, *e
;
6802 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
6804 if (!is_constant_array_expr (vector
)
6805 || !is_constant_array_expr (mask
)
6806 || (!gfc_is_constant_expr (field
)
6807 && !is_constant_array_expr (field
)))
6810 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
6812 if (vector
->ts
.type
== BT_DERIVED
)
6813 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
6814 result
->rank
= mask
->rank
;
6815 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
6817 if (vector
->ts
.type
== BT_CHARACTER
)
6818 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
6820 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
6821 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6823 = field
->expr_type
== EXPR_ARRAY
6824 ? gfc_constructor_first (field
->value
.constructor
)
6829 if (mask_ctor
->expr
->value
.logical
)
6831 gcc_assert (vector_ctor
);
6832 e
= gfc_copy_expr (vector_ctor
->expr
);
6833 vector_ctor
= gfc_constructor_next (vector_ctor
);
6835 else if (field
->expr_type
== EXPR_ARRAY
)
6836 e
= gfc_copy_expr (field_ctor
->expr
);
6838 e
= gfc_copy_expr (field
);
6840 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
6842 mask_ctor
= gfc_constructor_next (mask_ctor
);
6843 field_ctor
= gfc_constructor_next (field_ctor
);
6851 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
6855 size_t index
, len
, lenset
;
6857 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
6860 return &gfc_bad_expr
;
6862 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
6863 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
6866 if (b
!= NULL
&& b
->value
.logical
!= 0)
6871 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
6873 len
= s
->value
.character
.length
;
6874 lenset
= set
->value
.character
.length
;
6878 mpz_set_ui (result
->value
.integer
, 0);
6886 mpz_set_ui (result
->value
.integer
, 1);
6890 index
= wide_strspn (s
->value
.character
.string
,
6891 set
->value
.character
.string
) + 1;
6900 mpz_set_ui (result
->value
.integer
, len
);
6903 for (index
= len
; index
> 0; index
--)
6905 for (i
= 0; i
< lenset
; i
++)
6907 if (s
->value
.character
.string
[index
- 1]
6908 == set
->value
.character
.string
[i
])
6916 mpz_set_ui (result
->value
.integer
, index
);
6922 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
6927 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6930 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
6935 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
6936 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
6937 return range_check (result
, "XOR");
6940 return gfc_get_logical_expr (kind
, &x
->where
,
6941 (x
->value
.logical
&& !y
->value
.logical
)
6942 || (!x
->value
.logical
&& y
->value
.logical
));
6950 /****************** Constant simplification *****************/
6952 /* Master function to convert one constant to another. While this is
6953 used as a simplification function, it requires the destination type
6954 and kind information which is supplied by a special case in
6958 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
6960 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
6975 f
= gfc_int2complex
;
6995 f
= gfc_real2complex
;
7006 f
= gfc_complex2int
;
7009 f
= gfc_complex2real
;
7012 f
= gfc_complex2complex
;
7038 f
= gfc_hollerith2int
;
7042 f
= gfc_hollerith2real
;
7046 f
= gfc_hollerith2complex
;
7050 f
= gfc_hollerith2character
;
7054 f
= gfc_hollerith2logical
;
7064 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
7069 switch (e
->expr_type
)
7072 result
= f (e
, kind
);
7074 return &gfc_bad_expr
;
7078 if (!gfc_is_constant_expr (e
))
7081 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
7082 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
7083 result
->rank
= e
->rank
;
7085 for (c
= gfc_constructor_first (e
->value
.constructor
);
7086 c
; c
= gfc_constructor_next (c
))
7089 if (c
->iterator
== NULL
)
7090 tmp
= f (c
->expr
, kind
);
7093 g
= gfc_convert_constant (c
->expr
, type
, kind
);
7094 if (g
== &gfc_bad_expr
)
7096 gfc_free_expr (result
);
7104 gfc_free_expr (result
);
7108 gfc_constructor_append_expr (&result
->value
.constructor
,
7122 /* Function for converting character constants. */
7124 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
7129 if (!gfc_is_constant_expr (e
))
7132 if (e
->expr_type
== EXPR_CONSTANT
)
7134 /* Simple case of a scalar. */
7135 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
7137 return &gfc_bad_expr
;
7139 result
->value
.character
.length
= e
->value
.character
.length
;
7140 result
->value
.character
.string
7141 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
7142 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
7143 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
7145 /* Check we only have values representable in the destination kind. */
7146 for (i
= 0; i
< result
->value
.character
.length
; i
++)
7147 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
7150 gfc_error ("Character %qs in string at %L cannot be converted "
7151 "into character kind %d",
7152 gfc_print_wide_char (result
->value
.character
.string
[i
]),
7154 return &gfc_bad_expr
;
7159 else if (e
->expr_type
== EXPR_ARRAY
)
7161 /* For an array constructor, we convert each constructor element. */
7164 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
7165 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
7166 result
->rank
= e
->rank
;
7167 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
7169 for (c
= gfc_constructor_first (e
->value
.constructor
);
7170 c
; c
= gfc_constructor_next (c
))
7172 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
7173 if (tmp
== &gfc_bad_expr
)
7175 gfc_free_expr (result
);
7176 return &gfc_bad_expr
;
7181 gfc_free_expr (result
);
7185 gfc_constructor_append_expr (&result
->value
.constructor
,
7197 gfc_simplify_compiler_options (void)
7202 str
= gfc_get_option_string ();
7203 result
= gfc_get_character_expr (gfc_default_character_kind
,
7204 &gfc_current_locus
, str
, strlen (str
));
7211 gfc_simplify_compiler_version (void)
7216 len
= strlen ("GCC version ") + strlen (version_string
);
7217 buffer
= XALLOCAVEC (char, len
+ 1);
7218 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
7219 return gfc_get_character_expr (gfc_default_character_kind
,
7220 &gfc_current_locus
, buffer
, len
);
7223 /* Simplification routines for intrinsics of IEEE modules. */
7226 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
7228 gfc_actual_arglist
*arg
;
7229 gfc_expr
*p
= NULL
, *q
= NULL
, *rdx
= NULL
;
7231 arg
= expr
->value
.function
.actual
;
7235 q
= arg
->next
->expr
;
7236 if (arg
->next
->next
)
7237 rdx
= arg
->next
->next
->expr
;
7240 /* Currently, if IEEE is supported and this module is built, it means
7241 all our floating-point types conform to IEEE. Hence, we simply handle
7242 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
7243 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
7247 simplify_ieee_support (gfc_expr
*expr
)
7249 /* We consider that if the IEEE modules are loaded, we have full support
7250 for flags, halting and rounding, which are the three functions
7251 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
7252 expressions. One day, we will need libgfortran to detect support and
7253 communicate it back to us, allowing for partial support. */
7255 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
7260 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
7262 int n
= strlen(name
);
7264 if (!strncmp(sym
->name
, name
, n
))
7267 /* If a generic was used and renamed, we need more work to find out.
7268 Compare the specific name. */
7269 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
7276 gfc_simplify_ieee_functions (gfc_expr
*expr
)
7278 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
7280 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
7281 return simplify_ieee_selected_real_kind (expr
);
7282 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
7283 || matches_ieee_function_name(sym
, "ieee_support_halting")
7284 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
7285 return simplify_ieee_support (expr
);