1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
24 #include "tm.h" /* For BITS_PER_UNIT. */
27 #include "intrinsic.h"
28 #include "target-memory.h"
29 #include "constructor.h"
30 #include "version.h" /* For version_string. */
33 gfc_expr gfc_bad_expr
;
35 static gfc_expr
*simplify_size (gfc_expr
*, gfc_expr
*, int);
38 /* Note that 'simplification' is not just transforming expressions.
39 For functions that are not simplified at compile time, range
40 checking is done if possible.
42 The return convention is that each simplification function returns:
44 A new expression node corresponding to the simplified arguments.
45 The original arguments are destroyed by the caller, and must not
46 be a part of the new expression.
48 NULL pointer indicating that no simplification was possible and
49 the original expression should remain intact.
51 An expression pointer to gfc_bad_expr (a static placeholder)
52 indicating that some error has prevented simplification. The
53 error is generated within the function and should be propagated
56 By the time a simplification function gets control, it has been
57 decided that the function call is really supposed to be the
58 intrinsic. No type checking is strictly necessary, since only
59 valid types will be passed on. On the other hand, a simplification
60 subroutine may have to look at the type of an argument as part of
63 Array arguments are only passed to these subroutines that implement
64 the simplification of transformational intrinsics.
66 The functions in this file don't have much comment with them, but
67 everything is reasonably straight-forward. The Standard, chapter 13
68 is the best comment you'll find for this file anyway. */
70 /* Range checks an expression node. If all goes well, returns the
71 node, otherwise returns &gfc_bad_expr and frees the node. */
74 range_check (gfc_expr
*result
, const char *name
)
79 if (result
->expr_type
!= EXPR_CONSTANT
)
82 switch (gfc_range_check (result
))
88 gfc_error ("Result of %s overflows its kind at %L", name
,
93 gfc_error ("Result of %s underflows its kind at %L", name
,
98 gfc_error ("Result of %s is NaN at %L", name
, &result
->where
);
102 gfc_error ("Result of %s gives range error for its kind at %L", name
,
107 gfc_free_expr (result
);
108 return &gfc_bad_expr
;
112 /* A helper function that gets an optional and possibly missing
113 kind parameter. Returns the kind, -1 if something went wrong. */
116 get_kind (bt type
, gfc_expr
*k
, const char *name
, int default_kind
)
123 if (k
->expr_type
!= EXPR_CONSTANT
)
125 gfc_error ("KIND parameter of %s at %L must be an initialization "
126 "expression", name
, &k
->where
);
130 if (gfc_extract_int (k
, &kind
)
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, simplifying if
231 we are dealing with a parameter array. */
234 is_constant_array_expr (gfc_expr
*e
)
241 if (e
->expr_type
== EXPR_VARIABLE
&& e
->rank
> 0
242 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
243 gfc_simplify_expr (e
, 1);
245 if (e
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (e
))
248 for (c
= gfc_constructor_first (e
->value
.constructor
);
249 c
; c
= gfc_constructor_next (c
))
250 if (c
->expr
->expr_type
!= EXPR_CONSTANT
251 && c
->expr
->expr_type
!= EXPR_STRUCTURE
)
258 /* Initialize a transformational result expression with a given value. */
261 init_result_expr (gfc_expr
*e
, int init
, gfc_expr
*array
)
263 if (e
&& e
->expr_type
== EXPR_ARRAY
)
265 gfc_constructor
*ctor
= gfc_constructor_first (e
->value
.constructor
);
268 init_result_expr (ctor
->expr
, init
, array
);
269 ctor
= gfc_constructor_next (ctor
);
272 else if (e
&& e
->expr_type
== EXPR_CONSTANT
)
274 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
281 e
->value
.logical
= (init
? 1 : 0);
286 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].min_int
);
287 else if (init
== INT_MAX
)
288 mpz_set (e
->value
.integer
, gfc_integer_kinds
[i
].huge
);
290 mpz_set_si (e
->value
.integer
, init
);
296 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
297 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
299 else if (init
== INT_MAX
)
300 mpfr_set (e
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
302 mpfr_set_si (e
->value
.real
, init
, GFC_RND_MODE
);
306 mpc_set_si (e
->value
.complex, init
, GFC_MPC_RND_MODE
);
312 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
313 gfc_extract_int (len
, &length
);
314 string
= gfc_get_wide_string (length
+ 1);
315 gfc_wide_memset (string
, 0, length
);
317 else if (init
== INT_MAX
)
319 gfc_expr
*len
= gfc_simplify_len (array
, NULL
);
320 gfc_extract_int (len
, &length
);
321 string
= gfc_get_wide_string (length
+ 1);
322 gfc_wide_memset (string
, 255, length
);
327 string
= gfc_get_wide_string (1);
330 string
[length
] = '\0';
331 e
->value
.character
.length
= length
;
332 e
->value
.character
.string
= string
;
344 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
345 if conj_a is true, the matrix_a is complex conjugated. */
348 compute_dot_product (gfc_expr
*matrix_a
, int stride_a
, int offset_a
,
349 gfc_expr
*matrix_b
, int stride_b
, int offset_b
,
352 gfc_expr
*result
, *a
, *b
, *c
;
354 result
= gfc_get_constant_expr (matrix_a
->ts
.type
, matrix_a
->ts
.kind
,
356 init_result_expr (result
, 0, NULL
);
358 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
359 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
362 /* Copying of expressions is required as operands are free'd
363 by the gfc_arith routines. */
364 switch (result
->ts
.type
)
367 result
= gfc_or (result
,
368 gfc_and (gfc_copy_expr (a
),
375 if (conj_a
&& a
->ts
.type
== BT_COMPLEX
)
376 c
= gfc_simplify_conjg (a
);
378 c
= gfc_copy_expr (a
);
379 result
= gfc_add (result
, gfc_multiply (c
, gfc_copy_expr (b
)));
386 offset_a
+= stride_a
;
387 a
= gfc_constructor_lookup_expr (matrix_a
->value
.constructor
, offset_a
);
389 offset_b
+= stride_b
;
390 b
= gfc_constructor_lookup_expr (matrix_b
->value
.constructor
, offset_b
);
397 /* Build a result expression for transformational intrinsics,
401 transformational_result (gfc_expr
*array
, gfc_expr
*dim
, bt type
,
402 int kind
, locus
* where
)
407 if (!dim
|| array
->rank
== 1)
408 return gfc_get_constant_expr (type
, kind
, where
);
410 result
= gfc_get_array_expr (type
, kind
, where
);
411 result
->shape
= gfc_copy_shape_excluding (array
->shape
, array
->rank
, dim
);
412 result
->rank
= array
->rank
- 1;
414 /* gfc_array_size() would count the number of elements in the constructor,
415 we have not built those yet. */
417 for (i
= 0; i
< result
->rank
; ++i
)
418 nelem
*= mpz_get_ui (result
->shape
[i
]);
420 for (i
= 0; i
< nelem
; ++i
)
422 gfc_constructor_append_expr (&result
->value
.constructor
,
423 gfc_get_constant_expr (type
, kind
, where
),
431 typedef gfc_expr
* (*transformational_op
)(gfc_expr
*, gfc_expr
*);
433 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
434 of COUNT intrinsic is .TRUE..
436 Interface and implementation mimics arith functions as
437 gfc_add, gfc_multiply, etc. */
439 static gfc_expr
* gfc_count (gfc_expr
*op1
, gfc_expr
*op2
)
443 gcc_assert (op1
->ts
.type
== BT_INTEGER
);
444 gcc_assert (op2
->ts
.type
== BT_LOGICAL
);
445 gcc_assert (op2
->value
.logical
);
447 result
= gfc_copy_expr (op1
);
448 mpz_add_ui (result
->value
.integer
, result
->value
.integer
, 1);
456 /* Transforms an ARRAY with operation OP, according to MASK, to a
457 scalar RESULT. E.g. called if
459 REAL, PARAMETER :: array(n, m) = ...
460 REAL, PARAMETER :: s = SUM(array)
462 where OP == gfc_add(). */
465 simplify_transformation_to_scalar (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*mask
,
466 transformational_op op
)
469 gfc_constructor
*array_ctor
, *mask_ctor
;
471 /* Shortcut for constant .FALSE. MASK. */
473 && mask
->expr_type
== EXPR_CONSTANT
474 && !mask
->value
.logical
)
477 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
479 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
480 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
484 a
= array_ctor
->expr
;
485 array_ctor
= gfc_constructor_next (array_ctor
);
487 /* A constant MASK equals .TRUE. here and can be ignored. */
491 mask_ctor
= gfc_constructor_next (mask_ctor
);
492 if (!m
->value
.logical
)
496 result
= op (result
, gfc_copy_expr (a
));
504 /* Transforms an ARRAY with operation OP, according to MASK, to an
505 array RESULT. E.g. called if
507 REAL, PARAMETER :: array(n, m) = ...
508 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
510 where OP == gfc_multiply().
511 The result might be post processed using post_op. */
514 simplify_transformation_to_array (gfc_expr
*result
, gfc_expr
*array
, gfc_expr
*dim
,
515 gfc_expr
*mask
, transformational_op op
,
516 transformational_op post_op
)
519 int done
, i
, n
, arraysize
, resultsize
, dim_index
, dim_extent
, dim_stride
;
520 gfc_expr
**arrayvec
, **resultvec
, **base
, **src
, **dest
;
521 gfc_constructor
*array_ctor
, *mask_ctor
, *result_ctor
;
523 int count
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
],
524 sstride
[GFC_MAX_DIMENSIONS
], dstride
[GFC_MAX_DIMENSIONS
],
525 tmpstride
[GFC_MAX_DIMENSIONS
];
527 /* Shortcut for constant .FALSE. MASK. */
529 && mask
->expr_type
== EXPR_CONSTANT
530 && !mask
->value
.logical
)
533 /* Build an indexed table for array element expressions to minimize
534 linked-list traversal. Masked elements are set to NULL. */
535 gfc_array_size (array
, &size
);
536 arraysize
= mpz_get_ui (size
);
539 arrayvec
= XCNEWVEC (gfc_expr
*, arraysize
);
541 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
543 if (mask
&& mask
->expr_type
== EXPR_ARRAY
)
544 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
546 for (i
= 0; i
< arraysize
; ++i
)
548 arrayvec
[i
] = array_ctor
->expr
;
549 array_ctor
= gfc_constructor_next (array_ctor
);
553 if (!mask_ctor
->expr
->value
.logical
)
556 mask_ctor
= gfc_constructor_next (mask_ctor
);
560 /* Same for the result expression. */
561 gfc_array_size (result
, &size
);
562 resultsize
= mpz_get_ui (size
);
565 resultvec
= XCNEWVEC (gfc_expr
*, resultsize
);
566 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
567 for (i
= 0; i
< resultsize
; ++i
)
569 resultvec
[i
] = result_ctor
->expr
;
570 result_ctor
= gfc_constructor_next (result_ctor
);
573 gfc_extract_int (dim
, &dim_index
);
574 dim_index
-= 1; /* zero-base index */
578 for (i
= 0, n
= 0; i
< array
->rank
; ++i
)
581 tmpstride
[i
] = (i
== 0) ? 1 : tmpstride
[i
-1] * mpz_get_si (array
->shape
[i
-1]);
584 dim_extent
= mpz_get_si (array
->shape
[i
]);
585 dim_stride
= tmpstride
[i
];
589 extent
[n
] = mpz_get_si (array
->shape
[i
]);
590 sstride
[n
] = tmpstride
[i
];
591 dstride
[n
] = (n
== 0) ? 1 : dstride
[n
-1] * extent
[n
-1];
600 for (src
= base
, n
= 0; n
< dim_extent
; src
+= dim_stride
, ++n
)
602 *dest
= op (*dest
, gfc_copy_expr (*src
));
609 while (!done
&& count
[n
] == extent
[n
])
612 base
-= sstride
[n
] * extent
[n
];
613 dest
-= dstride
[n
] * extent
[n
];
616 if (n
< result
->rank
)
618 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
619 times, we'd warn for the last iteration, because the
620 array index will have already been incremented to the
621 array sizes, and we can't tell that this must make
622 the test against result->rank false, because ranks
623 must not exceed GFC_MAX_DIMENSIONS. */
624 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray
-bounds
)
635 /* Place updated expression in result constructor. */
636 result_ctor
= gfc_constructor_first (result
->value
.constructor
);
637 for (i
= 0; i
< resultsize
; ++i
)
640 result_ctor
->expr
= post_op (result_ctor
->expr
, resultvec
[i
]);
642 result_ctor
->expr
= resultvec
[i
];
643 result_ctor
= gfc_constructor_next (result_ctor
);
653 simplify_transformation (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
,
654 int init_val
, transformational_op op
)
658 if (!is_constant_array_expr (array
)
659 || !gfc_is_constant_expr (dim
))
663 && !is_constant_array_expr (mask
)
664 && mask
->expr_type
!= EXPR_CONSTANT
)
667 result
= transformational_result (array
, dim
, array
->ts
.type
,
668 array
->ts
.kind
, &array
->where
);
669 init_result_expr (result
, init_val
, NULL
);
671 return !dim
|| array
->rank
== 1 ?
672 simplify_transformation_to_scalar (result
, array
, mask
, op
) :
673 simplify_transformation_to_array (result
, array
, dim
, mask
, op
, NULL
);
677 /********************** Simplification functions *****************************/
680 gfc_simplify_abs (gfc_expr
*e
)
684 if (e
->expr_type
!= EXPR_CONSTANT
)
690 result
= gfc_get_constant_expr (BT_INTEGER
, e
->ts
.kind
, &e
->where
);
691 mpz_abs (result
->value
.integer
, e
->value
.integer
);
692 return range_check (result
, "IABS");
695 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
696 mpfr_abs (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
697 return range_check (result
, "ABS");
700 gfc_set_model_kind (e
->ts
.kind
);
701 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
702 mpc_abs (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
703 return range_check (result
, "CABS");
706 gfc_internal_error ("gfc_simplify_abs(): Bad type");
712 simplify_achar_char (gfc_expr
*e
, gfc_expr
*k
, const char *name
, bool ascii
)
716 bool too_large
= false;
718 if (e
->expr_type
!= EXPR_CONSTANT
)
721 kind
= get_kind (BT_CHARACTER
, k
, name
, gfc_default_character_kind
);
723 return &gfc_bad_expr
;
725 if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
727 gfc_error ("Argument of %s function at %L is negative", name
,
729 return &gfc_bad_expr
;
732 if (ascii
&& warn_surprising
&& mpz_cmp_si (e
->value
.integer
, 127) > 0)
733 gfc_warning (OPT_Wsurprising
,
734 "Argument of %s function at %L outside of range [0,127]",
737 if (kind
== 1 && mpz_cmp_si (e
->value
.integer
, 255) > 0)
742 mpz_init_set_ui (t
, 2);
743 mpz_pow_ui (t
, t
, 32);
744 mpz_sub_ui (t
, t
, 1);
745 if (mpz_cmp (e
->value
.integer
, t
) > 0)
752 gfc_error ("Argument of %s function at %L is too large for the "
753 "collating sequence of kind %d", name
, &e
->where
, kind
);
754 return &gfc_bad_expr
;
757 result
= gfc_get_character_expr (kind
, &e
->where
, NULL
, 1);
758 result
->value
.character
.string
[0] = mpz_get_ui (e
->value
.integer
);
765 /* We use the processor's collating sequence, because all
766 systems that gfortran currently works on are ASCII. */
769 gfc_simplify_achar (gfc_expr
*e
, gfc_expr
*k
)
771 return simplify_achar_char (e
, k
, "ACHAR", true);
776 gfc_simplify_acos (gfc_expr
*x
)
780 if (x
->expr_type
!= EXPR_CONSTANT
)
786 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
787 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
789 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
791 return &gfc_bad_expr
;
793 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
794 mpfr_acos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
798 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
799 mpc_acos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
803 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
806 return range_check (result
, "ACOS");
810 gfc_simplify_acosh (gfc_expr
*x
)
814 if (x
->expr_type
!= EXPR_CONSTANT
)
820 if (mpfr_cmp_si (x
->value
.real
, 1) < 0)
822 gfc_error ("Argument of ACOSH at %L must not be less than 1",
824 return &gfc_bad_expr
;
827 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
828 mpfr_acosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
832 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
833 mpc_acosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
837 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
840 return range_check (result
, "ACOSH");
844 gfc_simplify_adjustl (gfc_expr
*e
)
850 if (e
->expr_type
!= EXPR_CONSTANT
)
853 len
= e
->value
.character
.length
;
855 for (count
= 0, i
= 0; i
< len
; ++i
)
857 ch
= e
->value
.character
.string
[i
];
863 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
864 for (i
= 0; i
< len
- count
; ++i
)
865 result
->value
.character
.string
[i
] = e
->value
.character
.string
[count
+ i
];
872 gfc_simplify_adjustr (gfc_expr
*e
)
878 if (e
->expr_type
!= EXPR_CONSTANT
)
881 len
= e
->value
.character
.length
;
883 for (count
= 0, i
= len
- 1; i
>= 0; --i
)
885 ch
= e
->value
.character
.string
[i
];
891 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, len
);
892 for (i
= 0; i
< count
; ++i
)
893 result
->value
.character
.string
[i
] = ' ';
895 for (i
= count
; i
< len
; ++i
)
896 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
- count
];
903 gfc_simplify_aimag (gfc_expr
*e
)
907 if (e
->expr_type
!= EXPR_CONSTANT
)
910 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
911 mpfr_set (result
->value
.real
, mpc_imagref (e
->value
.complex), GFC_RND_MODE
);
913 return range_check (result
, "AIMAG");
918 gfc_simplify_aint (gfc_expr
*e
, gfc_expr
*k
)
920 gfc_expr
*rtrunc
, *result
;
923 kind
= get_kind (BT_REAL
, k
, "AINT", e
->ts
.kind
);
925 return &gfc_bad_expr
;
927 if (e
->expr_type
!= EXPR_CONSTANT
)
930 rtrunc
= gfc_copy_expr (e
);
931 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
933 result
= gfc_real2real (rtrunc
, kind
);
935 gfc_free_expr (rtrunc
);
937 return range_check (result
, "AINT");
942 gfc_simplify_all (gfc_expr
*mask
, gfc_expr
*dim
)
944 return simplify_transformation (mask
, dim
, NULL
, true, gfc_and
);
949 gfc_simplify_dint (gfc_expr
*e
)
951 gfc_expr
*rtrunc
, *result
;
953 if (e
->expr_type
!= EXPR_CONSTANT
)
956 rtrunc
= gfc_copy_expr (e
);
957 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
959 result
= gfc_real2real (rtrunc
, gfc_default_double_kind
);
961 gfc_free_expr (rtrunc
);
963 return range_check (result
, "DINT");
968 gfc_simplify_dreal (gfc_expr
*e
)
970 gfc_expr
*result
= NULL
;
972 if (e
->expr_type
!= EXPR_CONSTANT
)
975 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
976 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
978 return range_check (result
, "DREAL");
983 gfc_simplify_anint (gfc_expr
*e
, gfc_expr
*k
)
988 kind
= get_kind (BT_REAL
, k
, "ANINT", e
->ts
.kind
);
990 return &gfc_bad_expr
;
992 if (e
->expr_type
!= EXPR_CONSTANT
)
995 result
= gfc_get_constant_expr (e
->ts
.type
, kind
, &e
->where
);
996 mpfr_round (result
->value
.real
, e
->value
.real
);
998 return range_check (result
, "ANINT");
1003 gfc_simplify_and (gfc_expr
*x
, gfc_expr
*y
)
1008 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1011 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
1016 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
1017 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
1018 return range_check (result
, "AND");
1021 return gfc_get_logical_expr (kind
, &x
->where
,
1022 x
->value
.logical
&& y
->value
.logical
);
1031 gfc_simplify_any (gfc_expr
*mask
, gfc_expr
*dim
)
1033 return simplify_transformation (mask
, dim
, NULL
, false, gfc_or
);
1038 gfc_simplify_dnint (gfc_expr
*e
)
1042 if (e
->expr_type
!= EXPR_CONSTANT
)
1045 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &e
->where
);
1046 mpfr_round (result
->value
.real
, e
->value
.real
);
1048 return range_check (result
, "DNINT");
1053 gfc_simplify_asin (gfc_expr
*x
)
1057 if (x
->expr_type
!= EXPR_CONSTANT
)
1063 if (mpfr_cmp_si (x
->value
.real
, 1) > 0
1064 || mpfr_cmp_si (x
->value
.real
, -1) < 0)
1066 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1068 return &gfc_bad_expr
;
1070 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1071 mpfr_asin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1075 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1076 mpc_asin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1080 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1083 return range_check (result
, "ASIN");
1088 gfc_simplify_asinh (gfc_expr
*x
)
1092 if (x
->expr_type
!= EXPR_CONSTANT
)
1095 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1100 mpfr_asinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1104 mpc_asinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1108 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1111 return range_check (result
, "ASINH");
1116 gfc_simplify_atan (gfc_expr
*x
)
1120 if (x
->expr_type
!= EXPR_CONSTANT
)
1123 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1128 mpfr_atan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1132 mpc_atan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1136 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1139 return range_check (result
, "ATAN");
1144 gfc_simplify_atanh (gfc_expr
*x
)
1148 if (x
->expr_type
!= EXPR_CONSTANT
)
1154 if (mpfr_cmp_si (x
->value
.real
, 1) >= 0
1155 || mpfr_cmp_si (x
->value
.real
, -1) <= 0)
1157 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1159 return &gfc_bad_expr
;
1161 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1162 mpfr_atanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1166 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1167 mpc_atanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1171 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1174 return range_check (result
, "ATANH");
1179 gfc_simplify_atan2 (gfc_expr
*y
, gfc_expr
*x
)
1183 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
1186 if (mpfr_zero_p (y
->value
.real
) && mpfr_zero_p (x
->value
.real
))
1188 gfc_error ("If first argument of ATAN2 %L is zero, then the "
1189 "second argument must not be zero", &x
->where
);
1190 return &gfc_bad_expr
;
1193 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1194 mpfr_atan2 (result
->value
.real
, y
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1196 return range_check (result
, "ATAN2");
1201 gfc_simplify_bessel_j0 (gfc_expr
*x
)
1205 if (x
->expr_type
!= EXPR_CONSTANT
)
1208 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1209 mpfr_j0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1211 return range_check (result
, "BESSEL_J0");
1216 gfc_simplify_bessel_j1 (gfc_expr
*x
)
1220 if (x
->expr_type
!= EXPR_CONSTANT
)
1223 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1224 mpfr_j1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1226 return range_check (result
, "BESSEL_J1");
1231 gfc_simplify_bessel_jn (gfc_expr
*order
, gfc_expr
*x
)
1236 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1239 n
= mpz_get_si (order
->value
.integer
);
1240 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1241 mpfr_jn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1243 return range_check (result
, "BESSEL_JN");
1247 /* Simplify transformational form of JN and YN. */
1250 gfc_simplify_bessel_n2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
,
1257 mpfr_t x2rev
, last1
, last2
;
1259 if (x
->expr_type
!= EXPR_CONSTANT
|| order1
->expr_type
!= EXPR_CONSTANT
1260 || order2
->expr_type
!= EXPR_CONSTANT
)
1263 n1
= mpz_get_si (order1
->value
.integer
);
1264 n2
= mpz_get_si (order2
->value
.integer
);
1265 result
= gfc_get_array_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1267 result
->shape
= gfc_get_shape (1);
1268 mpz_init_set_ui (result
->shape
[0], MAX (n2
-n1
+1, 0));
1273 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1274 YN(N, 0.0) = -Inf. */
1276 if (mpfr_cmp_ui (x
->value
.real
, 0.0) == 0)
1278 if (!jn
&& flag_range_check
)
1280 gfc_error ("Result of BESSEL_YN is -INF at %L", &result
->where
);
1281 gfc_free_expr (result
);
1282 return &gfc_bad_expr
;
1287 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1288 mpfr_set_ui (e
->value
.real
, 1, GFC_RND_MODE
);
1289 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1294 for (i
= n1
; i
<= n2
; i
++)
1296 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1298 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
1300 mpfr_set_inf (e
->value
.real
, -1);
1301 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1308 /* Use the faster but more verbose recurrence algorithm. Bessel functions
1309 are stable for downward recursion and Neumann functions are stable
1310 for upward recursion. It is
1312 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1313 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1314 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1316 gfc_set_model_kind (x
->ts
.kind
);
1318 /* Get first recursion anchor. */
1322 mpfr_jn (last1
, n2
, x
->value
.real
, GFC_RND_MODE
);
1324 mpfr_yn (last1
, n1
, x
->value
.real
, GFC_RND_MODE
);
1326 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1327 mpfr_set (e
->value
.real
, last1
, GFC_RND_MODE
);
1328 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1332 gfc_free_expr (result
);
1333 return &gfc_bad_expr
;
1335 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1343 /* Get second recursion anchor. */
1347 mpfr_jn (last2
, n2
-1, x
->value
.real
, GFC_RND_MODE
);
1349 mpfr_yn (last2
, n1
+1, x
->value
.real
, GFC_RND_MODE
);
1351 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1352 mpfr_set (e
->value
.real
, last2
, GFC_RND_MODE
);
1353 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1358 gfc_free_expr (result
);
1359 return &gfc_bad_expr
;
1362 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
, -2);
1364 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1373 /* Start actual recursion. */
1376 mpfr_ui_div (x2rev
, 2, x
->value
.real
, GFC_RND_MODE
);
1378 for (i
= 2; i
<= n2
-n1
; i
++)
1380 e
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1382 /* Special case: For YN, if the previous N gave -INF, set
1383 also N+1 to -INF. */
1384 if (!jn
&& !flag_range_check
&& mpfr_inf_p (last2
))
1386 mpfr_set_inf (e
->value
.real
, -1);
1387 gfc_constructor_append_expr (&result
->value
.constructor
, e
,
1392 mpfr_mul_si (e
->value
.real
, x2rev
, jn
? (n2
-i
+1) : (n1
+i
-1),
1394 mpfr_mul (e
->value
.real
, e
->value
.real
, last2
, GFC_RND_MODE
);
1395 mpfr_sub (e
->value
.real
, e
->value
.real
, last1
, GFC_RND_MODE
);
1397 if (range_check (e
, jn
? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr
)
1399 /* Range_check frees "e" in that case. */
1405 gfc_constructor_insert_expr (&result
->value
.constructor
, e
, &x
->where
,
1408 gfc_constructor_append_expr (&result
->value
.constructor
, e
, &x
->where
);
1410 mpfr_set (last1
, last2
, GFC_RND_MODE
);
1411 mpfr_set (last2
, e
->value
.real
, GFC_RND_MODE
);
1424 gfc_free_expr (result
);
1425 return &gfc_bad_expr
;
1430 gfc_simplify_bessel_jn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1432 return gfc_simplify_bessel_n2 (order1
, order2
, x
, true);
1437 gfc_simplify_bessel_y0 (gfc_expr
*x
)
1441 if (x
->expr_type
!= EXPR_CONSTANT
)
1444 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1445 mpfr_y0 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1447 return range_check (result
, "BESSEL_Y0");
1452 gfc_simplify_bessel_y1 (gfc_expr
*x
)
1456 if (x
->expr_type
!= EXPR_CONSTANT
)
1459 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1460 mpfr_y1 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1462 return range_check (result
, "BESSEL_Y1");
1467 gfc_simplify_bessel_yn (gfc_expr
*order
, gfc_expr
*x
)
1472 if (x
->expr_type
!= EXPR_CONSTANT
|| order
->expr_type
!= EXPR_CONSTANT
)
1475 n
= mpz_get_si (order
->value
.integer
);
1476 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1477 mpfr_yn (result
->value
.real
, n
, x
->value
.real
, GFC_RND_MODE
);
1479 return range_check (result
, "BESSEL_YN");
1484 gfc_simplify_bessel_yn2 (gfc_expr
*order1
, gfc_expr
*order2
, gfc_expr
*x
)
1486 return gfc_simplify_bessel_n2 (order1
, order2
, x
, false);
1491 gfc_simplify_bit_size (gfc_expr
*e
)
1493 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
1494 return gfc_get_int_expr (e
->ts
.kind
, &e
->where
,
1495 gfc_integer_kinds
[i
].bit_size
);
1500 gfc_simplify_btest (gfc_expr
*e
, gfc_expr
*bit
)
1504 if (e
->expr_type
!= EXPR_CONSTANT
|| bit
->expr_type
!= EXPR_CONSTANT
)
1507 if (gfc_extract_int (bit
, &b
) || b
< 0)
1508 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
, false);
1510 return gfc_get_logical_expr (gfc_default_logical_kind
, &e
->where
,
1511 mpz_tstbit (e
->value
.integer
, b
));
1516 compare_bitwise (gfc_expr
*i
, gfc_expr
*j
)
1521 gcc_assert (i
->ts
.type
== BT_INTEGER
);
1522 gcc_assert (j
->ts
.type
== BT_INTEGER
);
1524 mpz_init_set (x
, i
->value
.integer
);
1525 k
= gfc_validate_kind (i
->ts
.type
, i
->ts
.kind
, false);
1526 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
1528 mpz_init_set (y
, j
->value
.integer
);
1529 k
= gfc_validate_kind (j
->ts
.type
, j
->ts
.kind
, false);
1530 convert_mpz_to_unsigned (y
, gfc_integer_kinds
[k
].bit_size
);
1532 res
= mpz_cmp (x
, y
);
1540 gfc_simplify_bge (gfc_expr
*i
, gfc_expr
*j
)
1542 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1545 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1546 compare_bitwise (i
, j
) >= 0);
1551 gfc_simplify_bgt (gfc_expr
*i
, gfc_expr
*j
)
1553 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1556 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1557 compare_bitwise (i
, j
) > 0);
1562 gfc_simplify_ble (gfc_expr
*i
, gfc_expr
*j
)
1564 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1567 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1568 compare_bitwise (i
, j
) <= 0);
1573 gfc_simplify_blt (gfc_expr
*i
, gfc_expr
*j
)
1575 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
)
1578 return gfc_get_logical_expr (gfc_default_logical_kind
, &i
->where
,
1579 compare_bitwise (i
, j
) < 0);
1584 gfc_simplify_ceiling (gfc_expr
*e
, gfc_expr
*k
)
1586 gfc_expr
*ceil
, *result
;
1589 kind
= get_kind (BT_INTEGER
, k
, "CEILING", gfc_default_integer_kind
);
1591 return &gfc_bad_expr
;
1593 if (e
->expr_type
!= EXPR_CONSTANT
)
1596 ceil
= gfc_copy_expr (e
);
1597 mpfr_ceil (ceil
->value
.real
, e
->value
.real
);
1599 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
1600 gfc_mpfr_to_mpz (result
->value
.integer
, ceil
->value
.real
, &e
->where
);
1602 gfc_free_expr (ceil
);
1604 return range_check (result
, "CEILING");
1609 gfc_simplify_char (gfc_expr
*e
, gfc_expr
*k
)
1611 return simplify_achar_char (e
, k
, "CHAR", false);
1615 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1618 simplify_cmplx (const char *name
, gfc_expr
*x
, gfc_expr
*y
, int kind
)
1622 if (convert_boz (x
, kind
) == &gfc_bad_expr
)
1623 return &gfc_bad_expr
;
1625 if (convert_boz (y
, kind
) == &gfc_bad_expr
)
1626 return &gfc_bad_expr
;
1628 if (x
->expr_type
!= EXPR_CONSTANT
1629 || (y
!= NULL
&& y
->expr_type
!= EXPR_CONSTANT
))
1632 result
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &x
->where
);
1637 mpc_set_z (result
->value
.complex, x
->value
.integer
, GFC_MPC_RND_MODE
);
1641 mpc_set_fr (result
->value
.complex, x
->value
.real
, GFC_RND_MODE
);
1645 mpc_set (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1649 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1653 return range_check (result
, name
);
1658 mpfr_set_z (mpc_imagref (result
->value
.complex),
1659 y
->value
.integer
, GFC_RND_MODE
);
1663 mpfr_set (mpc_imagref (result
->value
.complex),
1664 y
->value
.real
, GFC_RND_MODE
);
1668 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1671 return range_check (result
, name
);
1676 gfc_simplify_cmplx (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*k
)
1680 kind
= get_kind (BT_REAL
, k
, "CMPLX", gfc_default_complex_kind
);
1682 return &gfc_bad_expr
;
1684 return simplify_cmplx ("CMPLX", x
, y
, kind
);
1689 gfc_simplify_complex (gfc_expr
*x
, gfc_expr
*y
)
1693 if (x
->ts
.type
== BT_INTEGER
&& y
->ts
.type
== BT_INTEGER
)
1694 kind
= gfc_default_complex_kind
;
1695 else if (x
->ts
.type
== BT_REAL
|| y
->ts
.type
== BT_INTEGER
)
1697 else if (x
->ts
.type
== BT_INTEGER
|| y
->ts
.type
== BT_REAL
)
1699 else if (x
->ts
.type
== BT_REAL
&& y
->ts
.type
== BT_REAL
)
1700 kind
= (x
->ts
.kind
> y
->ts
.kind
) ? x
->ts
.kind
: y
->ts
.kind
;
1704 return simplify_cmplx ("COMPLEX", x
, y
, kind
);
1709 gfc_simplify_conjg (gfc_expr
*e
)
1713 if (e
->expr_type
!= EXPR_CONSTANT
)
1716 result
= gfc_copy_expr (e
);
1717 mpc_conj (result
->value
.complex, result
->value
.complex, GFC_MPC_RND_MODE
);
1719 return range_check (result
, "CONJG");
1722 /* Return the simplification of the constant expression in icall, or NULL
1723 if the expression is not constant. */
1726 simplify_trig_call (gfc_expr
*icall
)
1728 gfc_isym_id func
= icall
->value
.function
.isym
->id
;
1729 gfc_expr
*x
= icall
->value
.function
.actual
->expr
;
1731 /* The actual simplifiers will return NULL for non-constant x. */
1735 return gfc_simplify_acos (x
);
1737 return gfc_simplify_asin (x
);
1739 return gfc_simplify_atan (x
);
1741 return gfc_simplify_cos (x
);
1742 case GFC_ISYM_COTAN
:
1743 return gfc_simplify_cotan (x
);
1745 return gfc_simplify_sin (x
);
1747 return gfc_simplify_tan (x
);
1749 gfc_internal_error ("in simplify_trig_call(): Bad intrinsic");
1753 /* Convert a floating-point number from radians to degrees. */
1756 degrees_f (mpfr_t x
, mp_rnd_t rnd_mode
)
1761 /* Set x = x % 2pi to avoid offsets with large angles. */
1762 mpfr_const_pi (tmp
, rnd_mode
);
1763 mpfr_mul_ui (tmp
, tmp
, 2, rnd_mode
);
1764 mpfr_fmod (tmp
, x
, tmp
, rnd_mode
);
1766 /* Set x = x * 180. */
1767 mpfr_mul_ui (x
, x
, 180, rnd_mode
);
1769 /* Set x = x / pi. */
1770 mpfr_const_pi (tmp
, rnd_mode
);
1771 mpfr_div (x
, x
, tmp
, rnd_mode
);
1776 /* Convert a floating-point number from degrees to radians. */
1779 radians_f (mpfr_t x
, mp_rnd_t rnd_mode
)
1784 /* Set x = x % 360 to avoid offsets with large angles. */
1785 mpfr_set_ui (tmp
, 360, rnd_mode
);
1786 mpfr_fmod (tmp
, x
, tmp
, rnd_mode
);
1788 /* Set x = x * pi. */
1789 mpfr_const_pi (tmp
, rnd_mode
);
1790 mpfr_mul (x
, x
, tmp
, rnd_mode
);
1792 /* Set x = x / 180. */
1793 mpfr_div_ui (x
, x
, 180, rnd_mode
);
1799 /* Convert argument to radians before calling a trig function. */
1802 gfc_simplify_trigd (gfc_expr
*icall
)
1806 arg
= icall
->value
.function
.actual
->expr
;
1808 if (arg
->ts
.type
!= BT_REAL
)
1809 gfc_internal_error ("in gfc_simplify_trigd(): Bad type");
1811 if (arg
->expr_type
== EXPR_CONSTANT
)
1812 /* Convert constant to radians before passing off to simplifier. */
1813 radians_f (arg
->value
.real
, GFC_RND_MODE
);
1815 /* Let the usual simplifier take over - we just simplified the arg. */
1816 return simplify_trig_call (icall
);
1819 /* Convert result of an inverse trig function to degrees. */
1822 gfc_simplify_atrigd (gfc_expr
*icall
)
1826 if (icall
->value
.function
.actual
->expr
->ts
.type
!= BT_REAL
)
1827 gfc_internal_error ("in gfc_simplify_atrigd(): Bad type");
1829 /* See if another simplifier has work to do first. */
1830 result
= simplify_trig_call (icall
);
1832 if (result
&& result
->expr_type
== EXPR_CONSTANT
)
1834 /* Convert constant to degrees after passing off to actual simplifier. */
1835 degrees_f (result
->value
.real
, GFC_RND_MODE
);
1839 /* Let gfc_resolve_atrigd take care of the non-constant case. */
1843 /* Convert the result of atan2 to degrees. */
1846 gfc_simplify_atan2d (gfc_expr
*y
, gfc_expr
*x
)
1850 if (x
->ts
.type
!= BT_REAL
|| y
->ts
.type
!= BT_REAL
)
1851 gfc_internal_error ("in gfc_simplify_atan2d(): Bad type");
1853 if (x
->expr_type
== EXPR_CONSTANT
&& y
->expr_type
== EXPR_CONSTANT
)
1855 result
= gfc_simplify_atan2 (y
, x
);
1858 degrees_f (result
->value
.real
, GFC_RND_MODE
);
1863 /* Let gfc_resolve_atan2d take care of the non-constant case. */
1868 gfc_simplify_cos (gfc_expr
*x
)
1872 if (x
->expr_type
!= EXPR_CONSTANT
)
1875 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1880 mpfr_cos (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1884 gfc_set_model_kind (x
->ts
.kind
);
1885 mpc_cos (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1889 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1892 return range_check (result
, "COS");
1897 gfc_simplify_cosh (gfc_expr
*x
)
1901 if (x
->expr_type
!= EXPR_CONSTANT
)
1904 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
1909 mpfr_cosh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
1913 mpc_cosh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
1920 return range_check (result
, "COSH");
1925 gfc_simplify_count (gfc_expr
*mask
, gfc_expr
*dim
, gfc_expr
*kind
)
1929 if (!is_constant_array_expr (mask
)
1930 || !gfc_is_constant_expr (dim
)
1931 || !gfc_is_constant_expr (kind
))
1934 result
= transformational_result (mask
, dim
,
1936 get_kind (BT_INTEGER
, kind
, "COUNT",
1937 gfc_default_integer_kind
),
1940 init_result_expr (result
, 0, NULL
);
1942 /* Passing MASK twice, once as data array, once as mask.
1943 Whenever gfc_count is called, '1' is added to the result. */
1944 return !dim
|| mask
->rank
== 1 ?
1945 simplify_transformation_to_scalar (result
, mask
, mask
, gfc_count
) :
1946 simplify_transformation_to_array (result
, mask
, dim
, mask
, gfc_count
, NULL
);
1951 gfc_simplify_cshift (gfc_expr
*array
, gfc_expr
*shift
, gfc_expr
*dim
)
1953 gfc_expr
*a
, *result
;
1956 /* DIM is only useful for rank > 1, but deal with it here as one can
1957 set DIM = 1 for rank = 1. */
1960 if (!gfc_is_constant_expr (dim
))
1962 dm
= mpz_get_si (dim
->value
.integer
);
1967 /* Copy array into 'a', simplify it, and then test for a constant array. */
1968 a
= gfc_copy_expr (array
);
1969 gfc_simplify_expr (a
, 0);
1970 if (!is_constant_array_expr (a
))
1978 gfc_constructor
*ca
, *cr
;
1982 if (!gfc_is_constant_expr (shift
))
1988 shft
= mpz_get_si (shift
->value
.integer
);
1990 /* Case (i): If ARRAY has rank one, element i of the result is
1991 ARRAY (1 + MODULO (i + SHIFT - 1, SIZE (ARRAY))). */
1994 gfc_array_size (a
, &size
);
1995 sz
= mpz_get_si (size
);
1998 /* Adjust shft to deal with right or left shifts. */
1999 shft
= shft
< 0 ? 1 - shft
: shft
;
2001 /* Special case: Shift to the original order! */
2002 if (sz
== 0 || shft
% sz
== 0)
2005 result
= gfc_copy_expr (a
);
2006 cr
= gfc_constructor_first (result
->value
.constructor
);
2007 for (i
= 0; i
< sz
; i
++, cr
= gfc_constructor_next (cr
))
2009 j
= (i
+ shft
) % sz
;
2010 ca
= gfc_constructor_first (a
->value
.constructor
);
2012 ca
= gfc_constructor_next (ca
);
2013 cr
->expr
= gfc_copy_expr (ca
->expr
);
2021 /* FIXME: Deal with rank > 1 arrays. For now, don't leak memory. */
2023 /* GCC bootstrap is too stupid to realize that the above code for dm
2024 is correct. First, dim can be specified for a rank 1 array. It is
2025 not needed in this nor used here. Second, the code is simply waiting
2026 for someone to implement rank > 1 simplification. For now, add a
2027 pessimization to the code that has a zero valid reason to be here. */
2028 if (dm
> array
->rank
)
2039 gfc_simplify_dcmplx (gfc_expr
*x
, gfc_expr
*y
)
2041 return simplify_cmplx ("DCMPLX", x
, y
, gfc_default_double_kind
);
2046 gfc_simplify_dble (gfc_expr
*e
)
2048 gfc_expr
*result
= NULL
;
2050 if (e
->expr_type
!= EXPR_CONSTANT
)
2053 if (convert_boz (e
, gfc_default_double_kind
) == &gfc_bad_expr
)
2054 return &gfc_bad_expr
;
2056 result
= gfc_convert_constant (e
, BT_REAL
, gfc_default_double_kind
);
2057 if (result
== &gfc_bad_expr
)
2058 return &gfc_bad_expr
;
2060 return range_check (result
, "DBLE");
2065 gfc_simplify_digits (gfc_expr
*x
)
2069 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2074 digits
= gfc_integer_kinds
[i
].digits
;
2079 digits
= gfc_real_kinds
[i
].digits
;
2086 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, digits
);
2091 gfc_simplify_dim (gfc_expr
*x
, gfc_expr
*y
)
2096 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2099 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
2100 result
= gfc_get_constant_expr (x
->ts
.type
, kind
, &x
->where
);
2105 if (mpz_cmp (x
->value
.integer
, y
->value
.integer
) > 0)
2106 mpz_sub (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2108 mpz_set_ui (result
->value
.integer
, 0);
2113 if (mpfr_cmp (x
->value
.real
, y
->value
.real
) > 0)
2114 mpfr_sub (result
->value
.real
, x
->value
.real
, y
->value
.real
,
2117 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
2122 gfc_internal_error ("gfc_simplify_dim(): Bad type");
2125 return range_check (result
, "DIM");
2130 gfc_simplify_dot_product (gfc_expr
*vector_a
, gfc_expr
*vector_b
)
2135 if (!is_constant_array_expr (vector_a
)
2136 || !is_constant_array_expr (vector_b
))
2139 gcc_assert (vector_a
->rank
== 1);
2140 gcc_assert (vector_b
->rank
== 1);
2142 temp
.expr_type
= EXPR_OP
;
2143 gfc_clear_ts (&temp
.ts
);
2144 temp
.value
.op
.op
= INTRINSIC_NONE
;
2145 temp
.value
.op
.op1
= vector_a
;
2146 temp
.value
.op
.op2
= vector_b
;
2147 gfc_type_convert_binary (&temp
, 1);
2149 return compute_dot_product (vector_a
, 1, 0, vector_b
, 1, 0, true);
2154 gfc_simplify_dprod (gfc_expr
*x
, gfc_expr
*y
)
2156 gfc_expr
*a1
, *a2
, *result
;
2158 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2161 a1
= gfc_real2real (x
, gfc_default_double_kind
);
2162 a2
= gfc_real2real (y
, gfc_default_double_kind
);
2164 result
= gfc_get_constant_expr (BT_REAL
, gfc_default_double_kind
, &x
->where
);
2165 mpfr_mul (result
->value
.real
, a1
->value
.real
, a2
->value
.real
, GFC_RND_MODE
);
2170 return range_check (result
, "DPROD");
2175 simplify_dshift (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
,
2179 int i
, k
, size
, shift
;
2181 if (arg1
->expr_type
!= EXPR_CONSTANT
|| arg2
->expr_type
!= EXPR_CONSTANT
2182 || shiftarg
->expr_type
!= EXPR_CONSTANT
)
2185 k
= gfc_validate_kind (BT_INTEGER
, arg1
->ts
.kind
, false);
2186 size
= gfc_integer_kinds
[k
].bit_size
;
2188 gfc_extract_int (shiftarg
, &shift
);
2190 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2192 shift
= size
- shift
;
2194 result
= gfc_get_constant_expr (BT_INTEGER
, arg1
->ts
.kind
, &arg1
->where
);
2195 mpz_set_ui (result
->value
.integer
, 0);
2197 for (i
= 0; i
< shift
; i
++)
2198 if (mpz_tstbit (arg2
->value
.integer
, size
- shift
+ i
))
2199 mpz_setbit (result
->value
.integer
, i
);
2201 for (i
= 0; i
< size
- shift
; i
++)
2202 if (mpz_tstbit (arg1
->value
.integer
, i
))
2203 mpz_setbit (result
->value
.integer
, shift
+ i
);
2205 /* Convert to a signed value. */
2206 gfc_convert_mpz_to_signed (result
->value
.integer
, size
);
2213 gfc_simplify_dshiftr (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2215 return simplify_dshift (arg1
, arg2
, shiftarg
, true);
2220 gfc_simplify_dshiftl (gfc_expr
*arg1
, gfc_expr
*arg2
, gfc_expr
*shiftarg
)
2222 return simplify_dshift (arg1
, arg2
, shiftarg
, false);
2227 gfc_simplify_erf (gfc_expr
*x
)
2231 if (x
->expr_type
!= EXPR_CONSTANT
)
2234 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2235 mpfr_erf (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2237 return range_check (result
, "ERF");
2242 gfc_simplify_erfc (gfc_expr
*x
)
2246 if (x
->expr_type
!= EXPR_CONSTANT
)
2249 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2250 mpfr_erfc (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2252 return range_check (result
, "ERFC");
2256 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2258 #define MAX_ITER 200
2259 #define ARG_LIMIT 12
2261 /* Calculate ERFC_SCALED directly by its definition:
2263 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2265 using a large precision for intermediate results. This is used for all
2266 but large values of the argument. */
2268 fullprec_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2273 prec
= mpfr_get_default_prec ();
2274 mpfr_set_default_prec (10 * prec
);
2279 mpfr_set (a
, arg
, GFC_RND_MODE
);
2280 mpfr_sqr (b
, a
, GFC_RND_MODE
);
2281 mpfr_exp (b
, b
, GFC_RND_MODE
);
2282 mpfr_erfc (a
, a
, GFC_RND_MODE
);
2283 mpfr_mul (a
, a
, b
, GFC_RND_MODE
);
2285 mpfr_set (res
, a
, GFC_RND_MODE
);
2286 mpfr_set_default_prec (prec
);
2292 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2294 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2295 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2298 This is used for large values of the argument. Intermediate calculations
2299 are performed with twice the precision. We don't do a fixed number of
2300 iterations of the sum, but stop when it has converged to the required
2303 asympt_erfc_scaled (mpfr_t res
, mpfr_t arg
)
2305 mpfr_t sum
, x
, u
, v
, w
, oldsum
, sumtrunc
;
2310 prec
= mpfr_get_default_prec ();
2311 mpfr_set_default_prec (2 * prec
);
2321 mpfr_init (sumtrunc
);
2322 mpfr_set_prec (oldsum
, prec
);
2323 mpfr_set_prec (sumtrunc
, prec
);
2325 mpfr_set (x
, arg
, GFC_RND_MODE
);
2326 mpfr_set_ui (sum
, 1, GFC_RND_MODE
);
2327 mpz_set_ui (num
, 1);
2329 mpfr_set (u
, x
, GFC_RND_MODE
);
2330 mpfr_sqr (u
, u
, GFC_RND_MODE
);
2331 mpfr_mul_ui (u
, u
, 2, GFC_RND_MODE
);
2332 mpfr_pow_si (u
, u
, -1, GFC_RND_MODE
);
2334 for (i
= 1; i
< MAX_ITER
; i
++)
2336 mpfr_set (oldsum
, sum
, GFC_RND_MODE
);
2338 mpz_mul_ui (num
, num
, 2 * i
- 1);
2341 mpfr_set (w
, u
, GFC_RND_MODE
);
2342 mpfr_pow_ui (w
, w
, i
, GFC_RND_MODE
);
2344 mpfr_set_z (v
, num
, GFC_RND_MODE
);
2345 mpfr_mul (v
, v
, w
, GFC_RND_MODE
);
2347 mpfr_add (sum
, sum
, v
, GFC_RND_MODE
);
2349 mpfr_set (sumtrunc
, sum
, GFC_RND_MODE
);
2350 if (mpfr_cmp (sumtrunc
, oldsum
) == 0)
2354 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2356 gcc_assert (i
< MAX_ITER
);
2358 /* Divide by x * sqrt(Pi). */
2359 mpfr_const_pi (u
, GFC_RND_MODE
);
2360 mpfr_sqrt (u
, u
, GFC_RND_MODE
);
2361 mpfr_mul (u
, u
, x
, GFC_RND_MODE
);
2362 mpfr_div (sum
, sum
, u
, GFC_RND_MODE
);
2364 mpfr_set (res
, sum
, GFC_RND_MODE
);
2365 mpfr_set_default_prec (prec
);
2367 mpfr_clears (sum
, x
, u
, v
, w
, oldsum
, sumtrunc
, NULL
);
2373 gfc_simplify_erfc_scaled (gfc_expr
*x
)
2377 if (x
->expr_type
!= EXPR_CONSTANT
)
2380 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2381 if (mpfr_cmp_d (x
->value
.real
, ARG_LIMIT
) >= 0)
2382 asympt_erfc_scaled (result
->value
.real
, x
->value
.real
);
2384 fullprec_erfc_scaled (result
->value
.real
, x
->value
.real
);
2386 return range_check (result
, "ERFC_SCALED");
2394 gfc_simplify_epsilon (gfc_expr
*e
)
2399 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2401 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
2402 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].epsilon
, GFC_RND_MODE
);
2404 return range_check (result
, "EPSILON");
2409 gfc_simplify_exp (gfc_expr
*x
)
2413 if (x
->expr_type
!= EXPR_CONSTANT
)
2416 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2421 mpfr_exp (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2425 gfc_set_model_kind (x
->ts
.kind
);
2426 mpc_exp (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
2430 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2433 return range_check (result
, "EXP");
2438 gfc_simplify_exponent (gfc_expr
*x
)
2443 if (x
->expr_type
!= EXPR_CONSTANT
)
2446 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2449 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2450 if (mpfr_inf_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
2452 int i
= gfc_validate_kind (BT_INTEGER
, gfc_default_integer_kind
, false);
2453 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2457 /* EXPONENT(+/- 0.0) = 0 */
2458 if (mpfr_zero_p (x
->value
.real
))
2460 mpz_set_ui (result
->value
.integer
, 0);
2464 gfc_set_model (x
->value
.real
);
2466 val
= (long int) mpfr_get_exp (x
->value
.real
);
2467 mpz_set_si (result
->value
.integer
, val
);
2469 return range_check (result
, "EXPONENT");
2474 gfc_simplify_failed_or_stopped_images (gfc_expr
*team ATTRIBUTE_UNUSED
,
2477 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2479 gfc_current_locus
= *gfc_current_intrinsic_where
;
2480 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2481 return &gfc_bad_expr
;
2484 if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
2489 gfc_extract_int (kind
, &actual_kind
);
2491 actual_kind
= gfc_default_integer_kind
;
2493 result
= gfc_get_array_expr (BT_INTEGER
, actual_kind
, &gfc_current_locus
);
2498 /* For fcoarray = lib no simplification is possible, because it is not known
2499 what images failed or are stopped at compile time. */
2505 gfc_simplify_float (gfc_expr
*a
)
2509 if (a
->expr_type
!= EXPR_CONSTANT
)
2514 if (convert_boz (a
, gfc_default_real_kind
) == &gfc_bad_expr
)
2515 return &gfc_bad_expr
;
2517 result
= gfc_copy_expr (a
);
2520 result
= gfc_int2real (a
, gfc_default_real_kind
);
2522 return range_check (result
, "FLOAT");
2527 is_last_ref_vtab (gfc_expr
*e
)
2530 gfc_component
*comp
= NULL
;
2532 if (e
->expr_type
!= EXPR_VARIABLE
)
2535 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2536 if (ref
->type
== REF_COMPONENT
)
2537 comp
= ref
->u
.c
.component
;
2539 if (!e
->ref
|| !comp
)
2540 return e
->symtree
->n
.sym
->attr
.vtab
;
2542 if (comp
->name
[0] == '_' && strcmp (comp
->name
, "_vptr") == 0)
2550 gfc_simplify_extends_type_of (gfc_expr
*a
, gfc_expr
*mold
)
2552 /* Avoid simplification of resolved symbols. */
2553 if (is_last_ref_vtab (a
) || is_last_ref_vtab (mold
))
2556 if (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_DERIVED
)
2557 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2558 gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2561 if (UNLIMITED_POLY (a
) || UNLIMITED_POLY (mold
))
2564 /* Return .false. if the dynamic type can never be an extension. */
2565 if ((a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_CLASS
2566 && !gfc_type_is_extension_of
2567 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2568 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
2569 && !gfc_type_is_extension_of
2570 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
2571 mold
->ts
.u
.derived
->components
->ts
.u
.derived
))
2572 || (a
->ts
.type
== BT_DERIVED
&& mold
->ts
.type
== BT_CLASS
2573 && !gfc_type_is_extension_of
2574 (mold
->ts
.u
.derived
->components
->ts
.u
.derived
,
2576 || (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
2577 && !gfc_type_is_extension_of
2578 (mold
->ts
.u
.derived
,
2579 a
->ts
.u
.derived
->components
->ts
.u
.derived
)
2580 && !gfc_type_is_extension_of
2581 (a
->ts
.u
.derived
->components
->ts
.u
.derived
,
2582 mold
->ts
.u
.derived
)))
2583 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2585 /* Return .true. if the dynamic type is guaranteed to be an extension. */
2586 if (a
->ts
.type
== BT_CLASS
&& mold
->ts
.type
== BT_DERIVED
2587 && gfc_type_is_extension_of (mold
->ts
.u
.derived
,
2588 a
->ts
.u
.derived
->components
->ts
.u
.derived
))
2589 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, true);
2596 gfc_simplify_same_type_as (gfc_expr
*a
, gfc_expr
*b
)
2598 /* Avoid simplification of resolved symbols. */
2599 if (is_last_ref_vtab (a
) || is_last_ref_vtab (b
))
2602 /* Return .false. if the dynamic type can never be the
2604 if (((a
->ts
.type
== BT_CLASS
&& gfc_expr_attr (a
).class_ok
)
2605 || (b
->ts
.type
== BT_CLASS
&& gfc_expr_attr (b
).class_ok
))
2606 && !gfc_type_compatible (&a
->ts
, &b
->ts
)
2607 && !gfc_type_compatible (&b
->ts
, &a
->ts
))
2608 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
, false);
2610 if (a
->ts
.type
!= BT_DERIVED
|| b
->ts
.type
!= BT_DERIVED
)
2613 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
2614 gfc_compare_derived_types (a
->ts
.u
.derived
,
2620 gfc_simplify_floor (gfc_expr
*e
, gfc_expr
*k
)
2626 kind
= get_kind (BT_INTEGER
, k
, "FLOOR", gfc_default_integer_kind
);
2628 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2630 if (e
->expr_type
!= EXPR_CONSTANT
)
2633 mpfr_init2 (floor
, mpfr_get_prec (e
->value
.real
));
2634 mpfr_floor (floor
, e
->value
.real
);
2636 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
2637 gfc_mpfr_to_mpz (result
->value
.integer
, floor
, &e
->where
);
2641 return range_check (result
, "FLOOR");
2646 gfc_simplify_fraction (gfc_expr
*x
)
2650 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2651 mpfr_t absv
, exp
, pow2
;
2656 if (x
->expr_type
!= EXPR_CONSTANT
)
2659 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
2661 /* FRACTION(inf) = NaN. */
2662 if (mpfr_inf_p (x
->value
.real
))
2664 mpfr_set_nan (result
->value
.real
);
2668 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2670 /* MPFR versions before 3.1.0 do not include mpfr_frexp.
2671 TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
2673 if (mpfr_sgn (x
->value
.real
) == 0)
2675 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2679 gfc_set_model_kind (x
->ts
.kind
);
2684 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
2685 mpfr_log2 (exp
, absv
, GFC_RND_MODE
);
2687 mpfr_trunc (exp
, exp
);
2688 mpfr_add_ui (exp
, exp
, 1, GFC_RND_MODE
);
2690 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
2692 mpfr_div (result
->value
.real
, x
->value
.real
, pow2
, GFC_RND_MODE
);
2694 mpfr_clears (exp
, absv
, pow2
, NULL
);
2698 /* mpfr_frexp() correctly handles zeros and NaNs. */
2699 mpfr_frexp (&e
, result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2703 return range_check (result
, "FRACTION");
2708 gfc_simplify_gamma (gfc_expr
*x
)
2712 if (x
->expr_type
!= EXPR_CONSTANT
)
2715 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2716 mpfr_gamma (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
2718 return range_check (result
, "GAMMA");
2723 gfc_simplify_huge (gfc_expr
*e
)
2728 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
2729 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
2734 mpz_set (result
->value
.integer
, gfc_integer_kinds
[i
].huge
);
2738 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].huge
, GFC_RND_MODE
);
2750 gfc_simplify_hypot (gfc_expr
*x
, gfc_expr
*y
)
2754 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2757 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2758 mpfr_hypot (result
->value
.real
, x
->value
.real
, y
->value
.real
, GFC_RND_MODE
);
2759 return range_check (result
, "HYPOT");
2763 /* We use the processor's collating sequence, because all
2764 systems that gfortran currently works on are ASCII. */
2767 gfc_simplify_iachar (gfc_expr
*e
, gfc_expr
*kind
)
2773 if (e
->expr_type
!= EXPR_CONSTANT
)
2776 if (e
->value
.character
.length
!= 1)
2778 gfc_error ("Argument of IACHAR at %L must be of length one", &e
->where
);
2779 return &gfc_bad_expr
;
2782 index
= e
->value
.character
.string
[0];
2784 if (warn_surprising
&& index
> 127)
2785 gfc_warning (OPT_Wsurprising
,
2786 "Argument of IACHAR function at %L outside of range 0..127",
2789 k
= get_kind (BT_INTEGER
, kind
, "IACHAR", gfc_default_integer_kind
);
2791 return &gfc_bad_expr
;
2793 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2795 return range_check (result
, "IACHAR");
2800 do_bit_and (gfc_expr
*result
, gfc_expr
*e
)
2802 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2803 gcc_assert (result
->ts
.type
== BT_INTEGER
2804 && result
->expr_type
== EXPR_CONSTANT
);
2806 mpz_and (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2812 gfc_simplify_iall (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2814 return simplify_transformation (array
, dim
, mask
, -1, do_bit_and
);
2819 do_bit_ior (gfc_expr
*result
, gfc_expr
*e
)
2821 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
2822 gcc_assert (result
->ts
.type
== BT_INTEGER
2823 && result
->expr_type
== EXPR_CONSTANT
);
2825 mpz_ior (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
2831 gfc_simplify_iany (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
2833 return simplify_transformation (array
, dim
, mask
, 0, do_bit_ior
);
2838 gfc_simplify_iand (gfc_expr
*x
, gfc_expr
*y
)
2842 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2845 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
2846 mpz_and (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
2848 return range_check (result
, "IAND");
2853 gfc_simplify_ibclr (gfc_expr
*x
, gfc_expr
*y
)
2858 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2861 gfc_extract_int (y
, &pos
);
2863 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2865 result
= gfc_copy_expr (x
);
2867 convert_mpz_to_unsigned (result
->value
.integer
,
2868 gfc_integer_kinds
[k
].bit_size
);
2870 mpz_clrbit (result
->value
.integer
, pos
);
2872 gfc_convert_mpz_to_signed (result
->value
.integer
,
2873 gfc_integer_kinds
[k
].bit_size
);
2880 gfc_simplify_ibits (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*z
)
2887 if (x
->expr_type
!= EXPR_CONSTANT
2888 || y
->expr_type
!= EXPR_CONSTANT
2889 || z
->expr_type
!= EXPR_CONSTANT
)
2892 gfc_extract_int (y
, &pos
);
2893 gfc_extract_int (z
, &len
);
2895 k
= gfc_validate_kind (BT_INTEGER
, x
->ts
.kind
, false);
2897 bitsize
= gfc_integer_kinds
[k
].bit_size
;
2899 if (pos
+ len
> bitsize
)
2901 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2902 "bit size at %L", &y
->where
);
2903 return &gfc_bad_expr
;
2906 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
2907 convert_mpz_to_unsigned (result
->value
.integer
,
2908 gfc_integer_kinds
[k
].bit_size
);
2910 bits
= XCNEWVEC (int, bitsize
);
2912 for (i
= 0; i
< bitsize
; i
++)
2915 for (i
= 0; i
< len
; i
++)
2916 bits
[i
] = mpz_tstbit (x
->value
.integer
, i
+ pos
);
2918 for (i
= 0; i
< bitsize
; i
++)
2921 mpz_clrbit (result
->value
.integer
, i
);
2922 else if (bits
[i
] == 1)
2923 mpz_setbit (result
->value
.integer
, i
);
2925 gfc_internal_error ("IBITS: Bad bit");
2930 gfc_convert_mpz_to_signed (result
->value
.integer
,
2931 gfc_integer_kinds
[k
].bit_size
);
2938 gfc_simplify_ibset (gfc_expr
*x
, gfc_expr
*y
)
2943 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
2946 gfc_extract_int (y
, &pos
);
2948 k
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
2950 result
= gfc_copy_expr (x
);
2952 convert_mpz_to_unsigned (result
->value
.integer
,
2953 gfc_integer_kinds
[k
].bit_size
);
2955 mpz_setbit (result
->value
.integer
, pos
);
2957 gfc_convert_mpz_to_signed (result
->value
.integer
,
2958 gfc_integer_kinds
[k
].bit_size
);
2965 gfc_simplify_ichar (gfc_expr
*e
, gfc_expr
*kind
)
2971 if (e
->expr_type
!= EXPR_CONSTANT
)
2974 if (e
->value
.character
.length
!= 1)
2976 gfc_error ("Argument of ICHAR at %L must be of length one", &e
->where
);
2977 return &gfc_bad_expr
;
2980 index
= e
->value
.character
.string
[0];
2982 k
= get_kind (BT_INTEGER
, kind
, "ICHAR", gfc_default_integer_kind
);
2984 return &gfc_bad_expr
;
2986 result
= gfc_get_int_expr (k
, &e
->where
, index
);
2988 return range_check (result
, "ICHAR");
2993 gfc_simplify_ieor (gfc_expr
*x
, gfc_expr
*y
)
2997 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3000 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3001 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3003 return range_check (result
, "IEOR");
3008 gfc_simplify_index (gfc_expr
*x
, gfc_expr
*y
, gfc_expr
*b
, gfc_expr
*kind
)
3011 int back
, len
, lensub
;
3012 int i
, j
, k
, count
, index
= 0, start
;
3014 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
3015 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
3018 if (b
!= NULL
&& b
->value
.logical
!= 0)
3023 k
= get_kind (BT_INTEGER
, kind
, "INDEX", gfc_default_integer_kind
);
3025 return &gfc_bad_expr
;
3027 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
3029 len
= x
->value
.character
.length
;
3030 lensub
= y
->value
.character
.length
;
3034 mpz_set_si (result
->value
.integer
, 0);
3042 mpz_set_si (result
->value
.integer
, 1);
3045 else if (lensub
== 1)
3047 for (i
= 0; i
< len
; i
++)
3049 for (j
= 0; j
< lensub
; j
++)
3051 if (y
->value
.character
.string
[j
]
3052 == x
->value
.character
.string
[i
])
3062 for (i
= 0; i
< len
; i
++)
3064 for (j
= 0; j
< lensub
; j
++)
3066 if (y
->value
.character
.string
[j
]
3067 == x
->value
.character
.string
[i
])
3072 for (k
= 0; k
< lensub
; k
++)
3074 if (y
->value
.character
.string
[k
]
3075 == x
->value
.character
.string
[k
+ start
])
3079 if (count
== lensub
)
3094 mpz_set_si (result
->value
.integer
, len
+ 1);
3097 else if (lensub
== 1)
3099 for (i
= 0; i
< len
; i
++)
3101 for (j
= 0; j
< lensub
; j
++)
3103 if (y
->value
.character
.string
[j
]
3104 == x
->value
.character
.string
[len
- i
])
3106 index
= len
- i
+ 1;
3114 for (i
= 0; i
< len
; i
++)
3116 for (j
= 0; j
< lensub
; j
++)
3118 if (y
->value
.character
.string
[j
]
3119 == x
->value
.character
.string
[len
- i
])
3122 if (start
<= len
- lensub
)
3125 for (k
= 0; k
< lensub
; k
++)
3126 if (y
->value
.character
.string
[k
]
3127 == x
->value
.character
.string
[k
+ start
])
3130 if (count
== lensub
)
3147 mpz_set_si (result
->value
.integer
, index
);
3148 return range_check (result
, "INDEX");
3153 simplify_intconv (gfc_expr
*e
, int kind
, const char *name
)
3155 gfc_expr
*result
= NULL
;
3157 if (e
->expr_type
!= EXPR_CONSTANT
)
3160 result
= gfc_convert_constant (e
, BT_INTEGER
, kind
);
3161 if (result
== &gfc_bad_expr
)
3162 return &gfc_bad_expr
;
3164 return range_check (result
, name
);
3169 gfc_simplify_int (gfc_expr
*e
, gfc_expr
*k
)
3173 kind
= get_kind (BT_INTEGER
, k
, "INT", gfc_default_integer_kind
);
3175 return &gfc_bad_expr
;
3177 return simplify_intconv (e
, kind
, "INT");
3181 gfc_simplify_int2 (gfc_expr
*e
)
3183 return simplify_intconv (e
, 2, "INT2");
3188 gfc_simplify_int8 (gfc_expr
*e
)
3190 return simplify_intconv (e
, 8, "INT8");
3195 gfc_simplify_long (gfc_expr
*e
)
3197 return simplify_intconv (e
, 4, "LONG");
3202 gfc_simplify_ifix (gfc_expr
*e
)
3204 gfc_expr
*rtrunc
, *result
;
3206 if (e
->expr_type
!= EXPR_CONSTANT
)
3209 rtrunc
= gfc_copy_expr (e
);
3210 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3212 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3214 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3216 gfc_free_expr (rtrunc
);
3218 return range_check (result
, "IFIX");
3223 gfc_simplify_idint (gfc_expr
*e
)
3225 gfc_expr
*rtrunc
, *result
;
3227 if (e
->expr_type
!= EXPR_CONSTANT
)
3230 rtrunc
= gfc_copy_expr (e
);
3231 mpfr_trunc (rtrunc
->value
.real
, e
->value
.real
);
3233 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
3235 gfc_mpfr_to_mpz (result
->value
.integer
, rtrunc
->value
.real
, &e
->where
);
3237 gfc_free_expr (rtrunc
);
3239 return range_check (result
, "IDINT");
3244 gfc_simplify_ior (gfc_expr
*x
, gfc_expr
*y
)
3248 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
3251 result
= gfc_get_constant_expr (BT_INTEGER
, x
->ts
.kind
, &x
->where
);
3252 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
3254 return range_check (result
, "IOR");
3259 do_bit_xor (gfc_expr
*result
, gfc_expr
*e
)
3261 gcc_assert (e
->ts
.type
== BT_INTEGER
&& e
->expr_type
== EXPR_CONSTANT
);
3262 gcc_assert (result
->ts
.type
== BT_INTEGER
3263 && result
->expr_type
== EXPR_CONSTANT
);
3265 mpz_xor (result
->value
.integer
, result
->value
.integer
, e
->value
.integer
);
3271 gfc_simplify_iparity (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
3273 return simplify_transformation (array
, dim
, mask
, 0, do_bit_xor
);
3278 gfc_simplify_is_iostat_end (gfc_expr
*x
)
3280 if (x
->expr_type
!= EXPR_CONSTANT
)
3283 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3284 mpz_cmp_si (x
->value
.integer
,
3285 LIBERROR_END
) == 0);
3290 gfc_simplify_is_iostat_eor (gfc_expr
*x
)
3292 if (x
->expr_type
!= EXPR_CONSTANT
)
3295 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3296 mpz_cmp_si (x
->value
.integer
,
3297 LIBERROR_EOR
) == 0);
3302 gfc_simplify_isnan (gfc_expr
*x
)
3304 if (x
->expr_type
!= EXPR_CONSTANT
)
3307 return gfc_get_logical_expr (gfc_default_logical_kind
, &x
->where
,
3308 mpfr_nan_p (x
->value
.real
));
3312 /* Performs a shift on its first argument. Depending on the last
3313 argument, the shift can be arithmetic, i.e. with filling from the
3314 left like in the SHIFTA intrinsic. */
3316 simplify_shift (gfc_expr
*e
, gfc_expr
*s
, const char *name
,
3317 bool arithmetic
, int direction
)
3320 int ashift
, *bits
, i
, k
, bitsize
, shift
;
3322 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3325 gfc_extract_int (s
, &shift
);
3327 k
= gfc_validate_kind (BT_INTEGER
, e
->ts
.kind
, false);
3328 bitsize
= gfc_integer_kinds
[k
].bit_size
;
3330 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3334 mpz_set (result
->value
.integer
, e
->value
.integer
);
3338 if (direction
> 0 && shift
< 0)
3340 /* Left shift, as in SHIFTL. */
3341 gfc_error ("Second argument of %s is negative at %L", name
, &e
->where
);
3342 return &gfc_bad_expr
;
3344 else if (direction
< 0)
3346 /* Right shift, as in SHIFTR or SHIFTA. */
3349 gfc_error ("Second argument of %s is negative at %L",
3351 return &gfc_bad_expr
;
3357 ashift
= (shift
>= 0 ? shift
: -shift
);
3359 if (ashift
> bitsize
)
3361 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3362 "at %L", name
, &e
->where
);
3363 return &gfc_bad_expr
;
3366 bits
= XCNEWVEC (int, bitsize
);
3368 for (i
= 0; i
< bitsize
; i
++)
3369 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3374 for (i
= 0; i
< shift
; i
++)
3375 mpz_clrbit (result
->value
.integer
, i
);
3377 for (i
= 0; i
< bitsize
- shift
; i
++)
3380 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3382 mpz_setbit (result
->value
.integer
, i
+ shift
);
3388 if (arithmetic
&& bits
[bitsize
- 1])
3389 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3390 mpz_setbit (result
->value
.integer
, i
);
3392 for (i
= bitsize
- 1; i
>= bitsize
- ashift
; i
--)
3393 mpz_clrbit (result
->value
.integer
, i
);
3395 for (i
= bitsize
- 1; i
>= ashift
; i
--)
3398 mpz_clrbit (result
->value
.integer
, i
- ashift
);
3400 mpz_setbit (result
->value
.integer
, i
- ashift
);
3404 gfc_convert_mpz_to_signed (result
->value
.integer
, bitsize
);
3412 gfc_simplify_ishft (gfc_expr
*e
, gfc_expr
*s
)
3414 return simplify_shift (e
, s
, "ISHFT", false, 0);
3419 gfc_simplify_lshift (gfc_expr
*e
, gfc_expr
*s
)
3421 return simplify_shift (e
, s
, "LSHIFT", false, 1);
3426 gfc_simplify_rshift (gfc_expr
*e
, gfc_expr
*s
)
3428 return simplify_shift (e
, s
, "RSHIFT", true, -1);
3433 gfc_simplify_shifta (gfc_expr
*e
, gfc_expr
*s
)
3435 return simplify_shift (e
, s
, "SHIFTA", true, -1);
3440 gfc_simplify_shiftl (gfc_expr
*e
, gfc_expr
*s
)
3442 return simplify_shift (e
, s
, "SHIFTL", false, 1);
3447 gfc_simplify_shiftr (gfc_expr
*e
, gfc_expr
*s
)
3449 return simplify_shift (e
, s
, "SHIFTR", false, -1);
3454 gfc_simplify_ishftc (gfc_expr
*e
, gfc_expr
*s
, gfc_expr
*sz
)
3457 int shift
, ashift
, isize
, ssize
, delta
, k
;
3460 if (e
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
3463 gfc_extract_int (s
, &shift
);
3465 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3466 isize
= gfc_integer_kinds
[k
].bit_size
;
3470 if (sz
->expr_type
!= EXPR_CONSTANT
)
3473 gfc_extract_int (sz
, &ssize
);
3486 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3487 "BIT_SIZE of first argument at %C");
3489 gfc_error ("Absolute value of SHIFT shall be less than or equal "
3491 return &gfc_bad_expr
;
3494 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
3496 mpz_set (result
->value
.integer
, e
->value
.integer
);
3501 convert_mpz_to_unsigned (result
->value
.integer
, isize
);
3503 bits
= XCNEWVEC (int, ssize
);
3505 for (i
= 0; i
< ssize
; i
++)
3506 bits
[i
] = mpz_tstbit (e
->value
.integer
, i
);
3508 delta
= ssize
- ashift
;
3512 for (i
= 0; i
< delta
; i
++)
3515 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3517 mpz_setbit (result
->value
.integer
, i
+ shift
);
3520 for (i
= delta
; i
< ssize
; i
++)
3523 mpz_clrbit (result
->value
.integer
, i
- delta
);
3525 mpz_setbit (result
->value
.integer
, i
- delta
);
3530 for (i
= 0; i
< ashift
; i
++)
3533 mpz_clrbit (result
->value
.integer
, i
+ delta
);
3535 mpz_setbit (result
->value
.integer
, i
+ delta
);
3538 for (i
= ashift
; i
< ssize
; i
++)
3541 mpz_clrbit (result
->value
.integer
, i
+ shift
);
3543 mpz_setbit (result
->value
.integer
, i
+ shift
);
3547 gfc_convert_mpz_to_signed (result
->value
.integer
, isize
);
3555 gfc_simplify_kind (gfc_expr
*e
)
3557 return gfc_get_int_expr (gfc_default_integer_kind
, NULL
, e
->ts
.kind
);
3562 simplify_bound_dim (gfc_expr
*array
, gfc_expr
*kind
, int d
, int upper
,
3563 gfc_array_spec
*as
, gfc_ref
*ref
, bool coarray
)
3565 gfc_expr
*l
, *u
, *result
;
3568 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3569 gfc_default_integer_kind
);
3571 return &gfc_bad_expr
;
3573 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3575 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3576 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3577 if (!coarray
&& array
->expr_type
!= EXPR_VARIABLE
)
3581 gfc_expr
* dim
= result
;
3582 mpz_set_si (dim
->value
.integer
, d
);
3584 result
= simplify_size (array
, dim
, k
);
3585 gfc_free_expr (dim
);
3590 mpz_set_si (result
->value
.integer
, 1);
3595 /* Otherwise, we have a variable expression. */
3596 gcc_assert (array
->expr_type
== EXPR_VARIABLE
);
3599 if (!gfc_resolve_array_spec (as
, 0))
3602 /* The last dimension of an assumed-size array is special. */
3603 if ((!coarray
&& d
== as
->rank
&& as
->type
== AS_ASSUMED_SIZE
&& !upper
)
3604 || (coarray
&& d
== as
->rank
+ as
->corank
3605 && (!upper
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)))
3607 if (as
->lower
[d
-1]->expr_type
== EXPR_CONSTANT
)
3609 gfc_free_expr (result
);
3610 return gfc_copy_expr (as
->lower
[d
-1]);
3616 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
3618 /* Then, we need to know the extent of the given dimension. */
3619 if (coarray
|| (ref
->u
.ar
.type
== AR_FULL
&& !ref
->next
))
3621 gfc_expr
*declared_bound
;
3623 bool constant_lbound
, constant_ubound
;
3628 gcc_assert (l
!= NULL
);
3630 constant_lbound
= l
->expr_type
== EXPR_CONSTANT
;
3631 constant_ubound
= u
&& u
->expr_type
== EXPR_CONSTANT
;
3633 empty_bound
= upper
? 0 : 1;
3634 declared_bound
= upper
? u
: l
;
3636 if ((!upper
&& !constant_lbound
)
3637 || (upper
&& !constant_ubound
))
3642 /* For {L,U}BOUND, the value depends on whether the array
3643 is empty. We can nevertheless simplify if the declared bound
3644 has the same value as that of an empty array, in which case
3645 the result isn't dependent on the array emptyness. */
3646 if (mpz_cmp_si (declared_bound
->value
.integer
, empty_bound
) == 0)
3647 mpz_set_si (result
->value
.integer
, empty_bound
);
3648 else if (!constant_lbound
|| !constant_ubound
)
3649 /* Array emptyness can't be determined, we can't simplify. */
3651 else if (mpz_cmp (l
->value
.integer
, u
->value
.integer
) > 0)
3652 mpz_set_si (result
->value
.integer
, empty_bound
);
3654 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
3657 mpz_set (result
->value
.integer
, declared_bound
->value
.integer
);
3663 if (!gfc_ref_dimen_size (&ref
->u
.ar
, d
- 1, &result
->value
.integer
, NULL
))
3667 mpz_set_si (result
->value
.integer
, (long int) 1);
3671 return range_check (result
, upper
? "UBOUND" : "LBOUND");
3674 gfc_free_expr (result
);
3680 simplify_bound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3686 if (array
->ts
.type
== BT_CLASS
)
3689 if (array
->expr_type
!= EXPR_VARIABLE
)
3696 /* Follow any component references. */
3697 as
= array
->symtree
->n
.sym
->as
;
3698 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3703 switch (ref
->u
.ar
.type
)
3710 /* We're done because 'as' has already been set in the
3711 previous iteration. */
3725 as
= ref
->u
.c
.component
->as
;
3737 if (as
&& (as
->type
== AS_DEFERRED
|| as
->type
== AS_ASSUMED_RANK
3738 || (as
->type
== AS_ASSUMED_SHAPE
&& upper
)))
3742 || (as
->type
!= AS_DEFERRED
3743 && array
->expr_type
== EXPR_VARIABLE
3744 && !gfc_expr_attr (array
).allocatable
3745 && !gfc_expr_attr (array
).pointer
));
3749 /* Multi-dimensional bounds. */
3750 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3754 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
3755 if (upper
&& as
&& as
->type
== AS_ASSUMED_SIZE
)
3757 /* An error message will be emitted in
3758 check_assumed_size_reference (resolve.c). */
3759 return &gfc_bad_expr
;
3762 /* Simplify the bounds for each dimension. */
3763 for (d
= 0; d
< array
->rank
; d
++)
3765 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1, upper
, as
, ref
,
3767 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3771 for (j
= 0; j
< d
; j
++)
3772 gfc_free_expr (bounds
[j
]);
3777 /* Allocate the result expression. */
3778 k
= get_kind (BT_INTEGER
, kind
, upper
? "UBOUND" : "LBOUND",
3779 gfc_default_integer_kind
);
3781 return &gfc_bad_expr
;
3783 e
= gfc_get_array_expr (BT_INTEGER
, k
, &array
->where
);
3785 /* The result is a rank 1 array; its size is the rank of the first
3786 argument to {L,U}BOUND. */
3788 e
->shape
= gfc_get_shape (1);
3789 mpz_init_set_ui (e
->shape
[0], array
->rank
);
3791 /* Create the constructor for this array. */
3792 for (d
= 0; d
< array
->rank
; d
++)
3793 gfc_constructor_append_expr (&e
->value
.constructor
,
3794 bounds
[d
], &e
->where
);
3800 /* A DIM argument is specified. */
3801 if (dim
->expr_type
!= EXPR_CONSTANT
)
3804 d
= mpz_get_si (dim
->value
.integer
);
3806 if ((d
< 1 || d
> array
->rank
)
3807 || (d
== array
->rank
&& as
&& as
->type
== AS_ASSUMED_SIZE
&& upper
))
3809 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3810 return &gfc_bad_expr
;
3813 if (as
&& as
->type
== AS_ASSUMED_RANK
)
3816 return simplify_bound_dim (array
, kind
, d
, upper
, as
, ref
, false);
3822 simplify_cobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
, int upper
)
3828 if (array
->expr_type
!= EXPR_VARIABLE
)
3831 /* Follow any component references. */
3832 as
= (array
->ts
.type
== BT_CLASS
&& array
->ts
.u
.derived
->components
)
3833 ? array
->ts
.u
.derived
->components
->as
3834 : array
->symtree
->n
.sym
->as
;
3835 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
3840 switch (ref
->u
.ar
.type
)
3843 if (ref
->u
.ar
.as
->corank
> 0)
3845 gcc_assert (as
== ref
->u
.ar
.as
);
3852 /* We're done because 'as' has already been set in the
3853 previous iteration. */
3867 as
= ref
->u
.c
.component
->as
;
3880 if (as
->cotype
== AS_DEFERRED
|| as
->cotype
== AS_ASSUMED_SHAPE
)
3885 /* Multi-dimensional cobounds. */
3886 gfc_expr
*bounds
[GFC_MAX_DIMENSIONS
];
3890 /* Simplify the cobounds for each dimension. */
3891 for (d
= 0; d
< as
->corank
; d
++)
3893 bounds
[d
] = simplify_bound_dim (array
, kind
, d
+ 1 + as
->rank
,
3894 upper
, as
, ref
, true);
3895 if (bounds
[d
] == NULL
|| bounds
[d
] == &gfc_bad_expr
)
3899 for (j
= 0; j
< d
; j
++)
3900 gfc_free_expr (bounds
[j
]);
3905 /* Allocate the result expression. */
3906 e
= gfc_get_expr ();
3907 e
->where
= array
->where
;
3908 e
->expr_type
= EXPR_ARRAY
;
3909 e
->ts
.type
= BT_INTEGER
;
3910 k
= get_kind (BT_INTEGER
, kind
, upper
? "UCOBOUND" : "LCOBOUND",
3911 gfc_default_integer_kind
);
3915 return &gfc_bad_expr
;
3919 /* The result is a rank 1 array; its size is the rank of the first
3920 argument to {L,U}COBOUND. */
3922 e
->shape
= gfc_get_shape (1);
3923 mpz_init_set_ui (e
->shape
[0], as
->corank
);
3925 /* Create the constructor for this array. */
3926 for (d
= 0; d
< as
->corank
; d
++)
3927 gfc_constructor_append_expr (&e
->value
.constructor
,
3928 bounds
[d
], &e
->where
);
3933 /* A DIM argument is specified. */
3934 if (dim
->expr_type
!= EXPR_CONSTANT
)
3937 d
= mpz_get_si (dim
->value
.integer
);
3939 if (d
< 1 || d
> as
->corank
)
3941 gfc_error ("DIM argument at %L is out of bounds", &dim
->where
);
3942 return &gfc_bad_expr
;
3945 return simplify_bound_dim (array
, kind
, d
+as
->rank
, upper
, as
, ref
, true);
3951 gfc_simplify_lbound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3953 return simplify_bound (array
, dim
, kind
, 0);
3958 gfc_simplify_lcobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
3960 return simplify_cobound (array
, dim
, kind
, 0);
3964 gfc_simplify_leadz (gfc_expr
*e
)
3966 unsigned long lz
, bs
;
3969 if (e
->expr_type
!= EXPR_CONSTANT
)
3972 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
3973 bs
= gfc_integer_kinds
[i
].bit_size
;
3974 if (mpz_cmp_si (e
->value
.integer
, 0) == 0)
3976 else if (mpz_cmp_si (e
->value
.integer
, 0) < 0)
3979 lz
= bs
- mpz_sizeinbase (e
->value
.integer
, 2);
3981 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, lz
);
3986 gfc_simplify_len (gfc_expr
*e
, gfc_expr
*kind
)
3989 int k
= get_kind (BT_INTEGER
, kind
, "LEN", gfc_default_integer_kind
);
3992 return &gfc_bad_expr
;
3994 if (e
->expr_type
== EXPR_CONSTANT
)
3996 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
3997 mpz_set_si (result
->value
.integer
, e
->value
.character
.length
);
3998 return range_check (result
, "LEN");
4000 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
4001 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
4002 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
4004 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &e
->where
);
4005 mpz_set (result
->value
.integer
, e
->ts
.u
.cl
->length
->value
.integer
);
4006 return range_check (result
, "LEN");
4008 else if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
4009 && e
->symtree
->n
.sym
4010 && e
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
4011 && e
->symtree
->n
.sym
->assoc
&& e
->symtree
->n
.sym
->assoc
->target
4012 && e
->symtree
->n
.sym
->assoc
->target
->ts
.type
== BT_DERIVED
4013 && e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
4014 && UNLIMITED_POLY (e
->symtree
->n
.sym
->assoc
->target
->symtree
->n
.sym
))
4016 /* The expression in assoc->target points to a ref to the _data component
4017 of the unlimited polymorphic entity. To get the _len component the last
4018 _data ref needs to be stripped and a ref to the _len component added. */
4019 return gfc_get_len_component (e
->symtree
->n
.sym
->assoc
->target
);
4026 gfc_simplify_len_trim (gfc_expr
*e
, gfc_expr
*kind
)
4030 int k
= get_kind (BT_INTEGER
, kind
, "LEN_TRIM", gfc_default_integer_kind
);
4033 return &gfc_bad_expr
;
4035 if (e
->expr_type
!= EXPR_CONSTANT
)
4038 len
= e
->value
.character
.length
;
4039 for (count
= 0, i
= 1; i
<= len
; i
++)
4040 if (e
->value
.character
.string
[len
- i
] == ' ')
4045 result
= gfc_get_int_expr (k
, &e
->where
, len
- count
);
4046 return range_check (result
, "LEN_TRIM");
4050 gfc_simplify_lgamma (gfc_expr
*x
)
4055 if (x
->expr_type
!= EXPR_CONSTANT
)
4058 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4059 mpfr_lgamma (result
->value
.real
, &sg
, x
->value
.real
, GFC_RND_MODE
);
4061 return range_check (result
, "LGAMMA");
4066 gfc_simplify_lge (gfc_expr
*a
, gfc_expr
*b
)
4068 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4071 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4072 gfc_compare_string (a
, b
) >= 0);
4077 gfc_simplify_lgt (gfc_expr
*a
, gfc_expr
*b
)
4079 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4082 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4083 gfc_compare_string (a
, b
) > 0);
4088 gfc_simplify_lle (gfc_expr
*a
, gfc_expr
*b
)
4090 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4093 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4094 gfc_compare_string (a
, b
) <= 0);
4099 gfc_simplify_llt (gfc_expr
*a
, gfc_expr
*b
)
4101 if (a
->expr_type
!= EXPR_CONSTANT
|| b
->expr_type
!= EXPR_CONSTANT
)
4104 return gfc_get_logical_expr (gfc_default_logical_kind
, &a
->where
,
4105 gfc_compare_string (a
, b
) < 0);
4110 gfc_simplify_log (gfc_expr
*x
)
4114 if (x
->expr_type
!= EXPR_CONSTANT
)
4117 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4122 if (mpfr_sgn (x
->value
.real
) <= 0)
4124 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4125 "to zero", &x
->where
);
4126 gfc_free_expr (result
);
4127 return &gfc_bad_expr
;
4130 mpfr_log (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4134 if (mpfr_zero_p (mpc_realref (x
->value
.complex))
4135 && mpfr_zero_p (mpc_imagref (x
->value
.complex)))
4137 gfc_error ("Complex argument of LOG at %L cannot be zero",
4139 gfc_free_expr (result
);
4140 return &gfc_bad_expr
;
4143 gfc_set_model_kind (x
->ts
.kind
);
4144 mpc_log (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
4148 gfc_internal_error ("gfc_simplify_log: bad type");
4151 return range_check (result
, "LOG");
4156 gfc_simplify_log10 (gfc_expr
*x
)
4160 if (x
->expr_type
!= EXPR_CONSTANT
)
4163 if (mpfr_sgn (x
->value
.real
) <= 0)
4165 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4166 "to zero", &x
->where
);
4167 return &gfc_bad_expr
;
4170 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
4171 mpfr_log10 (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
4173 return range_check (result
, "LOG10");
4178 gfc_simplify_logical (gfc_expr
*e
, gfc_expr
*k
)
4182 kind
= get_kind (BT_LOGICAL
, k
, "LOGICAL", gfc_default_logical_kind
);
4184 return &gfc_bad_expr
;
4186 if (e
->expr_type
!= EXPR_CONSTANT
)
4189 return gfc_get_logical_expr (kind
, &e
->where
, e
->value
.logical
);
4194 gfc_simplify_matmul (gfc_expr
*matrix_a
, gfc_expr
*matrix_b
)
4197 int row
, result_rows
, col
, result_columns
;
4198 int stride_a
, offset_a
, stride_b
, offset_b
;
4200 if (!is_constant_array_expr (matrix_a
)
4201 || !is_constant_array_expr (matrix_b
))
4204 gcc_assert (gfc_compare_types (&matrix_a
->ts
, &matrix_b
->ts
));
4205 result
= gfc_get_array_expr (matrix_a
->ts
.type
,
4209 if (matrix_a
->rank
== 1 && matrix_b
->rank
== 2)
4212 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4214 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4217 result
->shape
= gfc_get_shape (result
->rank
);
4218 mpz_init_set_si (result
->shape
[0], result_columns
);
4220 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 1)
4222 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4224 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4228 result
->shape
= gfc_get_shape (result
->rank
);
4229 mpz_init_set_si (result
->shape
[0], result_rows
);
4231 else if (matrix_a
->rank
== 2 && matrix_b
->rank
== 2)
4233 result_rows
= mpz_get_si (matrix_a
->shape
[0]);
4234 result_columns
= mpz_get_si (matrix_b
->shape
[1]);
4235 stride_a
= mpz_get_si (matrix_a
->shape
[0]);
4236 stride_b
= mpz_get_si (matrix_b
->shape
[0]);
4239 result
->shape
= gfc_get_shape (result
->rank
);
4240 mpz_init_set_si (result
->shape
[0], result_rows
);
4241 mpz_init_set_si (result
->shape
[1], result_columns
);
4246 offset_a
= offset_b
= 0;
4247 for (col
= 0; col
< result_columns
; ++col
)
4251 for (row
= 0; row
< result_rows
; ++row
)
4253 gfc_expr
*e
= compute_dot_product (matrix_a
, stride_a
, offset_a
,
4254 matrix_b
, 1, offset_b
, false);
4255 gfc_constructor_append_expr (&result
->value
.constructor
,
4261 offset_b
+= stride_b
;
4269 gfc_simplify_maskr (gfc_expr
*i
, gfc_expr
*kind_arg
)
4274 if (i
->expr_type
!= EXPR_CONSTANT
)
4277 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKR", gfc_default_integer_kind
);
4279 return &gfc_bad_expr
;
4280 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4282 bool fail
= gfc_extract_int (i
, &arg
);
4285 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4287 /* MASKR(n) = 2^n - 1 */
4288 mpz_set_ui (result
->value
.integer
, 1);
4289 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
, arg
);
4290 mpz_sub_ui (result
->value
.integer
, result
->value
.integer
, 1);
4292 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4299 gfc_simplify_maskl (gfc_expr
*i
, gfc_expr
*kind_arg
)
4305 if (i
->expr_type
!= EXPR_CONSTANT
)
4308 kind
= get_kind (BT_INTEGER
, kind_arg
, "MASKL", gfc_default_integer_kind
);
4310 return &gfc_bad_expr
;
4311 k
= gfc_validate_kind (BT_INTEGER
, kind
, false);
4313 bool fail
= gfc_extract_int (i
, &arg
);
4316 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &i
->where
);
4318 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4319 mpz_init_set_ui (z
, 1);
4320 mpz_mul_2exp (z
, z
, gfc_integer_kinds
[k
].bit_size
);
4321 mpz_set_ui (result
->value
.integer
, 1);
4322 mpz_mul_2exp (result
->value
.integer
, result
->value
.integer
,
4323 gfc_integer_kinds
[k
].bit_size
- arg
);
4324 mpz_sub (result
->value
.integer
, z
, result
->value
.integer
);
4327 gfc_convert_mpz_to_signed (result
->value
.integer
, gfc_integer_kinds
[k
].bit_size
);
4334 gfc_simplify_merge (gfc_expr
*tsource
, gfc_expr
*fsource
, gfc_expr
*mask
)
4337 gfc_constructor
*tsource_ctor
, *fsource_ctor
, *mask_ctor
;
4339 if (mask
->expr_type
== EXPR_CONSTANT
)
4340 return gfc_get_parentheses (gfc_copy_expr (mask
->value
.logical
4341 ? tsource
: fsource
));
4343 if (!mask
->rank
|| !is_constant_array_expr (mask
)
4344 || !is_constant_array_expr (tsource
) || !is_constant_array_expr (fsource
))
4347 result
= gfc_get_array_expr (tsource
->ts
.type
, tsource
->ts
.kind
,
4349 if (tsource
->ts
.type
== BT_DERIVED
)
4350 result
->ts
.u
.derived
= tsource
->ts
.u
.derived
;
4351 else if (tsource
->ts
.type
== BT_CHARACTER
)
4352 result
->ts
.u
.cl
= tsource
->ts
.u
.cl
;
4354 tsource_ctor
= gfc_constructor_first (tsource
->value
.constructor
);
4355 fsource_ctor
= gfc_constructor_first (fsource
->value
.constructor
);
4356 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
4360 if (mask_ctor
->expr
->value
.logical
)
4361 gfc_constructor_append_expr (&result
->value
.constructor
,
4362 gfc_copy_expr (tsource_ctor
->expr
),
4365 gfc_constructor_append_expr (&result
->value
.constructor
,
4366 gfc_copy_expr (fsource_ctor
->expr
),
4368 tsource_ctor
= gfc_constructor_next (tsource_ctor
);
4369 fsource_ctor
= gfc_constructor_next (fsource_ctor
);
4370 mask_ctor
= gfc_constructor_next (mask_ctor
);
4373 result
->shape
= gfc_get_shape (1);
4374 gfc_array_size (result
, &result
->shape
[0]);
4381 gfc_simplify_merge_bits (gfc_expr
*i
, gfc_expr
*j
, gfc_expr
*mask_expr
)
4383 mpz_t arg1
, arg2
, mask
;
4386 if (i
->expr_type
!= EXPR_CONSTANT
|| j
->expr_type
!= EXPR_CONSTANT
4387 || mask_expr
->expr_type
!= EXPR_CONSTANT
)
4390 result
= gfc_get_constant_expr (BT_INTEGER
, i
->ts
.kind
, &i
->where
);
4392 /* Convert all argument to unsigned. */
4393 mpz_init_set (arg1
, i
->value
.integer
);
4394 mpz_init_set (arg2
, j
->value
.integer
);
4395 mpz_init_set (mask
, mask_expr
->value
.integer
);
4397 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4398 mpz_and (arg1
, arg1
, mask
);
4399 mpz_com (mask
, mask
);
4400 mpz_and (arg2
, arg2
, mask
);
4401 mpz_ior (result
->value
.integer
, arg1
, arg2
);
4411 /* Selects between current value and extremum for simplify_min_max
4412 and simplify_minval_maxval. */
4414 min_max_choose (gfc_expr
*arg
, gfc_expr
*extremum
, int sign
)
4416 switch (arg
->ts
.type
)
4419 if (mpz_cmp (arg
->value
.integer
,
4420 extremum
->value
.integer
) * sign
> 0)
4421 mpz_set (extremum
->value
.integer
, arg
->value
.integer
);
4425 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4427 mpfr_max (extremum
->value
.real
, extremum
->value
.real
,
4428 arg
->value
.real
, GFC_RND_MODE
);
4430 mpfr_min (extremum
->value
.real
, extremum
->value
.real
,
4431 arg
->value
.real
, GFC_RND_MODE
);
4435 #define LENGTH(x) ((x)->value.character.length)
4436 #define STRING(x) ((x)->value.character.string)
4437 if (LENGTH (extremum
) < LENGTH(arg
))
4439 gfc_char_t
*tmp
= STRING(extremum
);
4441 STRING(extremum
) = gfc_get_wide_string (LENGTH(arg
) + 1);
4442 memcpy (STRING(extremum
), tmp
,
4443 LENGTH(extremum
) * sizeof (gfc_char_t
));
4444 gfc_wide_memset (&STRING(extremum
)[LENGTH(extremum
)], ' ',
4445 LENGTH(arg
) - LENGTH(extremum
));
4446 STRING(extremum
)[LENGTH(arg
)] = '\0'; /* For debugger */
4447 LENGTH(extremum
) = LENGTH(arg
);
4451 if (gfc_compare_string (arg
, extremum
) * sign
> 0)
4453 free (STRING(extremum
));
4454 STRING(extremum
) = gfc_get_wide_string (LENGTH(extremum
) + 1);
4455 memcpy (STRING(extremum
), STRING(arg
),
4456 LENGTH(arg
) * sizeof (gfc_char_t
));
4457 gfc_wide_memset (&STRING(extremum
)[LENGTH(arg
)], ' ',
4458 LENGTH(extremum
) - LENGTH(arg
));
4459 STRING(extremum
)[LENGTH(extremum
)] = '\0'; /* For debugger */
4466 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4471 /* This function is special since MAX() can take any number of
4472 arguments. The simplified expression is a rewritten version of the
4473 argument list containing at most one constant element. Other
4474 constant elements are deleted. Because the argument list has
4475 already been checked, this function always succeeds. sign is 1 for
4476 MAX(), -1 for MIN(). */
4479 simplify_min_max (gfc_expr
*expr
, int sign
)
4481 gfc_actual_arglist
*arg
, *last
, *extremum
;
4482 gfc_intrinsic_sym
* specific
;
4486 specific
= expr
->value
.function
.isym
;
4488 arg
= expr
->value
.function
.actual
;
4490 for (; arg
; last
= arg
, arg
= arg
->next
)
4492 if (arg
->expr
->expr_type
!= EXPR_CONSTANT
)
4495 if (extremum
== NULL
)
4501 min_max_choose (arg
->expr
, extremum
->expr
, sign
);
4503 /* Delete the extra constant argument. */
4504 last
->next
= arg
->next
;
4507 gfc_free_actual_arglist (arg
);
4511 /* If there is one value left, replace the function call with the
4513 if (expr
->value
.function
.actual
->next
!= NULL
)
4516 /* Convert to the correct type and kind. */
4517 if (expr
->ts
.type
!= BT_UNKNOWN
)
4518 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4519 expr
->ts
.type
, expr
->ts
.kind
);
4521 if (specific
->ts
.type
!= BT_UNKNOWN
)
4522 return gfc_convert_constant (expr
->value
.function
.actual
->expr
,
4523 specific
->ts
.type
, specific
->ts
.kind
);
4525 return gfc_copy_expr (expr
->value
.function
.actual
->expr
);
4530 gfc_simplify_min (gfc_expr
*e
)
4532 return simplify_min_max (e
, -1);
4537 gfc_simplify_max (gfc_expr
*e
)
4539 return simplify_min_max (e
, 1);
4543 /* This is a simplified version of simplify_min_max to provide
4544 simplification of minval and maxval for a vector. */
4547 simplify_minval_maxval (gfc_expr
*expr
, int sign
)
4549 gfc_constructor
*c
, *extremum
;
4550 gfc_intrinsic_sym
* specific
;
4553 specific
= expr
->value
.function
.isym
;
4555 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4556 c
; c
= gfc_constructor_next (c
))
4558 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4561 if (extremum
== NULL
)
4567 min_max_choose (c
->expr
, extremum
->expr
, sign
);
4570 if (extremum
== NULL
)
4573 /* Convert to the correct type and kind. */
4574 if (expr
->ts
.type
!= BT_UNKNOWN
)
4575 return gfc_convert_constant (extremum
->expr
,
4576 expr
->ts
.type
, expr
->ts
.kind
);
4578 if (specific
->ts
.type
!= BT_UNKNOWN
)
4579 return gfc_convert_constant (extremum
->expr
,
4580 specific
->ts
.type
, specific
->ts
.kind
);
4582 return gfc_copy_expr (extremum
->expr
);
4587 gfc_simplify_minval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4589 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4592 return simplify_minval_maxval (array
, -1);
4597 gfc_simplify_maxval (gfc_expr
*array
, gfc_expr
* dim
, gfc_expr
*mask
)
4599 if (array
->expr_type
!= EXPR_ARRAY
|| array
->rank
!= 1 || dim
|| mask
)
4602 return simplify_minval_maxval (array
, 1);
4607 gfc_simplify_maxexponent (gfc_expr
*x
)
4609 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4610 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4611 gfc_real_kinds
[i
].max_exponent
);
4616 gfc_simplify_minexponent (gfc_expr
*x
)
4618 int i
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
4619 return gfc_get_int_expr (gfc_default_integer_kind
, &x
->where
,
4620 gfc_real_kinds
[i
].min_exponent
);
4625 gfc_simplify_mod (gfc_expr
*a
, gfc_expr
*p
)
4630 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4633 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4634 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4639 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4641 /* Result is processor-dependent. */
4642 gfc_error ("Second argument MOD at %L is zero", &a
->where
);
4643 gfc_free_expr (result
);
4644 return &gfc_bad_expr
;
4646 mpz_tdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4650 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4652 /* Result is processor-dependent. */
4653 gfc_error ("Second argument of MOD at %L is zero", &p
->where
);
4654 gfc_free_expr (result
);
4655 return &gfc_bad_expr
;
4658 gfc_set_model_kind (kind
);
4659 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4664 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4667 return range_check (result
, "MOD");
4672 gfc_simplify_modulo (gfc_expr
*a
, gfc_expr
*p
)
4677 if (a
->expr_type
!= EXPR_CONSTANT
|| p
->expr_type
!= EXPR_CONSTANT
)
4680 kind
= a
->ts
.kind
> p
->ts
.kind
? a
->ts
.kind
: p
->ts
.kind
;
4681 result
= gfc_get_constant_expr (a
->ts
.type
, kind
, &a
->where
);
4686 if (mpz_cmp_ui (p
->value
.integer
, 0) == 0)
4688 /* Result is processor-dependent. This processor just opts
4689 to not handle it at all. */
4690 gfc_error ("Second argument of MODULO at %L is zero", &a
->where
);
4691 gfc_free_expr (result
);
4692 return &gfc_bad_expr
;
4694 mpz_fdiv_r (result
->value
.integer
, a
->value
.integer
, p
->value
.integer
);
4699 if (mpfr_cmp_ui (p
->value
.real
, 0) == 0)
4701 /* Result is processor-dependent. */
4702 gfc_error ("Second argument of MODULO at %L is zero", &p
->where
);
4703 gfc_free_expr (result
);
4704 return &gfc_bad_expr
;
4707 gfc_set_model_kind (kind
);
4708 mpfr_fmod (result
->value
.real
, a
->value
.real
, p
->value
.real
,
4710 if (mpfr_cmp_ui (result
->value
.real
, 0) != 0)
4712 if (mpfr_signbit (a
->value
.real
) != mpfr_signbit (p
->value
.real
))
4713 mpfr_add (result
->value
.real
, result
->value
.real
, p
->value
.real
,
4717 mpfr_copysign (result
->value
.real
, result
->value
.real
,
4718 p
->value
.real
, GFC_RND_MODE
);
4722 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4725 return range_check (result
, "MODULO");
4730 gfc_simplify_nearest (gfc_expr
*x
, gfc_expr
*s
)
4733 mp_exp_t emin
, emax
;
4736 if (x
->expr_type
!= EXPR_CONSTANT
|| s
->expr_type
!= EXPR_CONSTANT
)
4739 result
= gfc_copy_expr (x
);
4741 /* Save current values of emin and emax. */
4742 emin
= mpfr_get_emin ();
4743 emax
= mpfr_get_emax ();
4745 /* Set emin and emax for the current model number. */
4746 kind
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, 0);
4747 mpfr_set_emin ((mp_exp_t
) gfc_real_kinds
[kind
].min_exponent
-
4748 mpfr_get_prec(result
->value
.real
) + 1);
4749 mpfr_set_emax ((mp_exp_t
) gfc_real_kinds
[kind
].max_exponent
- 1);
4750 mpfr_check_range (result
->value
.real
, 0, GMP_RNDU
);
4752 if (mpfr_sgn (s
->value
.real
) > 0)
4754 mpfr_nextabove (result
->value
.real
);
4755 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDU
);
4759 mpfr_nextbelow (result
->value
.real
);
4760 mpfr_subnormalize (result
->value
.real
, 0, GMP_RNDD
);
4763 mpfr_set_emin (emin
);
4764 mpfr_set_emax (emax
);
4766 /* Only NaN can occur. Do not use range check as it gives an
4767 error for denormal numbers. */
4768 if (mpfr_nan_p (result
->value
.real
) && flag_range_check
)
4770 gfc_error ("Result of NEAREST is NaN at %L", &result
->where
);
4771 gfc_free_expr (result
);
4772 return &gfc_bad_expr
;
4780 simplify_nint (const char *name
, gfc_expr
*e
, gfc_expr
*k
)
4782 gfc_expr
*itrunc
, *result
;
4785 kind
= get_kind (BT_INTEGER
, k
, name
, gfc_default_integer_kind
);
4787 return &gfc_bad_expr
;
4789 if (e
->expr_type
!= EXPR_CONSTANT
)
4792 itrunc
= gfc_copy_expr (e
);
4793 mpfr_round (itrunc
->value
.real
, e
->value
.real
);
4795 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &e
->where
);
4796 gfc_mpfr_to_mpz (result
->value
.integer
, itrunc
->value
.real
, &e
->where
);
4798 gfc_free_expr (itrunc
);
4800 return range_check (result
, name
);
4805 gfc_simplify_new_line (gfc_expr
*e
)
4809 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 1);
4810 result
->value
.character
.string
[0] = '\n';
4817 gfc_simplify_nint (gfc_expr
*e
, gfc_expr
*k
)
4819 return simplify_nint ("NINT", e
, k
);
4824 gfc_simplify_idnint (gfc_expr
*e
)
4826 return simplify_nint ("IDNINT", e
, NULL
);
4831 add_squared (gfc_expr
*result
, gfc_expr
*e
)
4835 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4836 gcc_assert (result
->ts
.type
== BT_REAL
4837 && result
->expr_type
== EXPR_CONSTANT
);
4839 gfc_set_model_kind (result
->ts
.kind
);
4841 mpfr_pow_ui (tmp
, e
->value
.real
, 2, GFC_RND_MODE
);
4842 mpfr_add (result
->value
.real
, result
->value
.real
, tmp
,
4851 do_sqrt (gfc_expr
*result
, gfc_expr
*e
)
4853 gcc_assert (e
->ts
.type
== BT_REAL
&& e
->expr_type
== EXPR_CONSTANT
);
4854 gcc_assert (result
->ts
.type
== BT_REAL
4855 && result
->expr_type
== EXPR_CONSTANT
);
4857 mpfr_set (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
4858 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4864 gfc_simplify_norm2 (gfc_expr
*e
, gfc_expr
*dim
)
4868 if (!is_constant_array_expr (e
)
4869 || (dim
!= NULL
&& !gfc_is_constant_expr (dim
)))
4872 result
= transformational_result (e
, dim
, e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4873 init_result_expr (result
, 0, NULL
);
4875 if (!dim
|| e
->rank
== 1)
4877 result
= simplify_transformation_to_scalar (result
, e
, NULL
,
4879 mpfr_sqrt (result
->value
.real
, result
->value
.real
, GFC_RND_MODE
);
4882 result
= simplify_transformation_to_array (result
, e
, dim
, NULL
,
4883 add_squared
, &do_sqrt
);
4890 gfc_simplify_not (gfc_expr
*e
)
4894 if (e
->expr_type
!= EXPR_CONSTANT
)
4897 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
4898 mpz_com (result
->value
.integer
, e
->value
.integer
);
4900 return range_check (result
, "NOT");
4905 gfc_simplify_null (gfc_expr
*mold
)
4911 result
= gfc_copy_expr (mold
);
4912 result
->expr_type
= EXPR_NULL
;
4915 result
= gfc_get_null_expr (NULL
);
4922 gfc_simplify_num_images (gfc_expr
*distance ATTRIBUTE_UNUSED
, gfc_expr
*failed
)
4926 if (flag_coarray
== GFC_FCOARRAY_NONE
)
4928 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4929 return &gfc_bad_expr
;
4932 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
4935 if (failed
&& failed
->expr_type
!= EXPR_CONSTANT
)
4938 /* FIXME: gfc_current_locus is wrong. */
4939 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
4940 &gfc_current_locus
);
4942 if (failed
&& failed
->value
.logical
!= 0)
4943 mpz_set_si (result
->value
.integer
, 0);
4945 mpz_set_si (result
->value
.integer
, 1);
4952 gfc_simplify_or (gfc_expr
*x
, gfc_expr
*y
)
4957 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
4960 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
4965 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
4966 mpz_ior (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
4967 return range_check (result
, "OR");
4970 return gfc_get_logical_expr (kind
, &x
->where
,
4971 x
->value
.logical
|| y
->value
.logical
);
4979 gfc_simplify_pack (gfc_expr
*array
, gfc_expr
*mask
, gfc_expr
*vector
)
4982 gfc_constructor
*array_ctor
, *mask_ctor
, *vector_ctor
;
4984 if (!is_constant_array_expr (array
)
4985 || !is_constant_array_expr (vector
)
4986 || (!gfc_is_constant_expr (mask
)
4987 && !is_constant_array_expr (mask
)))
4990 result
= gfc_get_array_expr (array
->ts
.type
, array
->ts
.kind
, &array
->where
);
4991 if (array
->ts
.type
== BT_DERIVED
)
4992 result
->ts
.u
.derived
= array
->ts
.u
.derived
;
4994 array_ctor
= gfc_constructor_first (array
->value
.constructor
);
4995 vector_ctor
= vector
4996 ? gfc_constructor_first (vector
->value
.constructor
)
4999 if (mask
->expr_type
== EXPR_CONSTANT
5000 && mask
->value
.logical
)
5002 /* Copy all elements of ARRAY to RESULT. */
5005 gfc_constructor_append_expr (&result
->value
.constructor
,
5006 gfc_copy_expr (array_ctor
->expr
),
5009 array_ctor
= gfc_constructor_next (array_ctor
);
5010 vector_ctor
= gfc_constructor_next (vector_ctor
);
5013 else if (mask
->expr_type
== EXPR_ARRAY
)
5015 /* Copy only those elements of ARRAY to RESULT whose
5016 MASK equals .TRUE.. */
5017 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
5020 if (mask_ctor
->expr
->value
.logical
)
5022 gfc_constructor_append_expr (&result
->value
.constructor
,
5023 gfc_copy_expr (array_ctor
->expr
),
5025 vector_ctor
= gfc_constructor_next (vector_ctor
);
5028 array_ctor
= gfc_constructor_next (array_ctor
);
5029 mask_ctor
= gfc_constructor_next (mask_ctor
);
5033 /* Append any left-over elements from VECTOR to RESULT. */
5036 gfc_constructor_append_expr (&result
->value
.constructor
,
5037 gfc_copy_expr (vector_ctor
->expr
),
5039 vector_ctor
= gfc_constructor_next (vector_ctor
);
5042 result
->shape
= gfc_get_shape (1);
5043 gfc_array_size (result
, &result
->shape
[0]);
5045 if (array
->ts
.type
== BT_CHARACTER
)
5046 result
->ts
.u
.cl
= array
->ts
.u
.cl
;
5053 do_xor (gfc_expr
*result
, gfc_expr
*e
)
5055 gcc_assert (e
->ts
.type
== BT_LOGICAL
&& e
->expr_type
== EXPR_CONSTANT
);
5056 gcc_assert (result
->ts
.type
== BT_LOGICAL
5057 && result
->expr_type
== EXPR_CONSTANT
);
5059 result
->value
.logical
= result
->value
.logical
!= e
->value
.logical
;
5066 gfc_simplify_parity (gfc_expr
*e
, gfc_expr
*dim
)
5068 return simplify_transformation (e
, dim
, NULL
, 0, do_xor
);
5073 gfc_simplify_popcnt (gfc_expr
*e
)
5078 if (e
->expr_type
!= EXPR_CONSTANT
)
5081 k
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5083 /* Convert argument to unsigned, then count the '1' bits. */
5084 mpz_init_set (x
, e
->value
.integer
);
5085 convert_mpz_to_unsigned (x
, gfc_integer_kinds
[k
].bit_size
);
5086 res
= mpz_popcount (x
);
5089 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, res
);
5094 gfc_simplify_poppar (gfc_expr
*e
)
5099 if (e
->expr_type
!= EXPR_CONSTANT
)
5102 popcnt
= gfc_simplify_popcnt (e
);
5103 gcc_assert (popcnt
);
5105 bool fail
= gfc_extract_int (popcnt
, &i
);
5108 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
% 2);
5113 gfc_simplify_precision (gfc_expr
*e
)
5115 int i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5116 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
5117 gfc_real_kinds
[i
].precision
);
5122 gfc_simplify_product (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
5124 return simplify_transformation (array
, dim
, mask
, 1, gfc_multiply
);
5129 gfc_simplify_radix (gfc_expr
*e
)
5132 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5137 i
= gfc_integer_kinds
[i
].radix
;
5141 i
= gfc_real_kinds
[i
].radix
;
5148 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
5153 gfc_simplify_range (gfc_expr
*e
)
5156 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
5161 i
= gfc_integer_kinds
[i
].range
;
5166 i
= gfc_real_kinds
[i
].range
;
5173 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, i
);
5178 gfc_simplify_rank (gfc_expr
*e
)
5184 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, e
->rank
);
5189 gfc_simplify_real (gfc_expr
*e
, gfc_expr
*k
)
5191 gfc_expr
*result
= NULL
;
5194 if (e
->ts
.type
== BT_COMPLEX
)
5195 kind
= get_kind (BT_REAL
, k
, "REAL", e
->ts
.kind
);
5197 kind
= get_kind (BT_REAL
, k
, "REAL", gfc_default_real_kind
);
5200 return &gfc_bad_expr
;
5202 if (e
->expr_type
!= EXPR_CONSTANT
)
5205 if (convert_boz (e
, kind
) == &gfc_bad_expr
)
5206 return &gfc_bad_expr
;
5208 result
= gfc_convert_constant (e
, BT_REAL
, kind
);
5209 if (result
== &gfc_bad_expr
)
5210 return &gfc_bad_expr
;
5212 return range_check (result
, "REAL");
5217 gfc_simplify_realpart (gfc_expr
*e
)
5221 if (e
->expr_type
!= EXPR_CONSTANT
)
5224 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
5225 mpc_real (result
->value
.real
, e
->value
.complex, GFC_RND_MODE
);
5227 return range_check (result
, "REALPART");
5231 gfc_simplify_repeat (gfc_expr
*e
, gfc_expr
*n
)
5234 int i
, j
, len
, ncop
, nlen
;
5236 bool have_length
= false;
5238 /* If NCOPIES isn't a constant, there's nothing we can do. */
5239 if (n
->expr_type
!= EXPR_CONSTANT
)
5242 /* If NCOPIES is negative, it's an error. */
5243 if (mpz_sgn (n
->value
.integer
) < 0)
5245 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
5247 return &gfc_bad_expr
;
5250 /* If we don't know the character length, we can do no more. */
5251 if (e
->ts
.u
.cl
&& e
->ts
.u
.cl
->length
5252 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5254 len
= mpz_get_si (e
->ts
.u
.cl
->length
->value
.integer
);
5257 else if (e
->expr_type
== EXPR_CONSTANT
5258 && (e
->ts
.u
.cl
== NULL
|| e
->ts
.u
.cl
->length
== NULL
))
5260 len
= e
->value
.character
.length
;
5265 /* If the source length is 0, any value of NCOPIES is valid
5266 and everything behaves as if NCOPIES == 0. */
5269 mpz_set_ui (ncopies
, 0);
5271 mpz_set (ncopies
, n
->value
.integer
);
5273 /* Check that NCOPIES isn't too large. */
5279 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
5281 i
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
5285 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
,
5286 e
->ts
.u
.cl
->length
->value
.integer
);
5290 mpz_init_set_si (mlen
, len
);
5291 mpz_tdiv_q (max
, gfc_integer_kinds
[i
].huge
, mlen
);
5295 /* The check itself. */
5296 if (mpz_cmp (ncopies
, max
) > 0)
5299 mpz_clear (ncopies
);
5300 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
5302 return &gfc_bad_expr
;
5307 mpz_clear (ncopies
);
5309 /* For further simplification, we need the character string to be
5311 if (e
->expr_type
!= EXPR_CONSTANT
)
5315 (e
->ts
.u
.cl
->length
&&
5316 mpz_sgn (e
->ts
.u
.cl
->length
->value
.integer
) != 0))
5318 bool fail
= gfc_extract_int (n
, &ncop
);
5325 return gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, 0);
5327 len
= e
->value
.character
.length
;
5330 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, nlen
);
5331 for (i
= 0; i
< ncop
; i
++)
5332 for (j
= 0; j
< len
; j
++)
5333 result
->value
.character
.string
[j
+i
*len
]= e
->value
.character
.string
[j
];
5335 result
->value
.character
.string
[nlen
] = '\0'; /* For debugger */
5340 /* This one is a bear, but mainly has to do with shuffling elements. */
5343 gfc_simplify_reshape (gfc_expr
*source
, gfc_expr
*shape_exp
,
5344 gfc_expr
*pad
, gfc_expr
*order_exp
)
5346 int order
[GFC_MAX_DIMENSIONS
], shape
[GFC_MAX_DIMENSIONS
];
5347 int i
, rank
, npad
, x
[GFC_MAX_DIMENSIONS
];
5351 gfc_expr
*e
, *result
;
5353 /* Check that argument expression types are OK. */
5354 if (!is_constant_array_expr (source
)
5355 || !is_constant_array_expr (shape_exp
)
5356 || !is_constant_array_expr (pad
)
5357 || !is_constant_array_expr (order_exp
))
5360 if (source
->shape
== NULL
)
5363 /* Proceed with simplification, unpacking the array. */
5370 e
= gfc_constructor_lookup_expr (shape_exp
->value
.constructor
, rank
);
5374 gfc_extract_int (e
, &shape
[rank
]);
5376 gcc_assert (rank
>= 0 && rank
< GFC_MAX_DIMENSIONS
);
5377 gcc_assert (shape
[rank
] >= 0);
5382 gcc_assert (rank
> 0);
5384 /* Now unpack the order array if present. */
5385 if (order_exp
== NULL
)
5387 for (i
= 0; i
< rank
; i
++)
5392 for (i
= 0; i
< rank
; i
++)
5395 for (i
= 0; i
< rank
; i
++)
5397 e
= gfc_constructor_lookup_expr (order_exp
->value
.constructor
, i
);
5400 gfc_extract_int (e
, &order
[i
]);
5402 gcc_assert (order
[i
] >= 1 && order
[i
] <= rank
);
5404 gcc_assert (x
[order
[i
]] == 0);
5409 /* Count the elements in the source and padding arrays. */
5414 gfc_array_size (pad
, &size
);
5415 npad
= mpz_get_ui (size
);
5419 gfc_array_size (source
, &size
);
5420 nsource
= mpz_get_ui (size
);
5423 /* If it weren't for that pesky permutation we could just loop
5424 through the source and round out any shortage with pad elements.
5425 But no, someone just had to have the compiler do something the
5426 user should be doing. */
5428 for (i
= 0; i
< rank
; i
++)
5431 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
5433 if (source
->ts
.type
== BT_DERIVED
)
5434 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
5435 result
->rank
= rank
;
5436 result
->shape
= gfc_get_shape (rank
);
5437 for (i
= 0; i
< rank
; i
++)
5438 mpz_init_set_ui (result
->shape
[i
], shape
[i
]);
5440 while (nsource
> 0 || npad
> 0)
5442 /* Figure out which element to extract. */
5443 mpz_set_ui (index
, 0);
5445 for (i
= rank
- 1; i
>= 0; i
--)
5447 mpz_add_ui (index
, index
, x
[order
[i
]]);
5449 mpz_mul_ui (index
, index
, shape
[order
[i
- 1]]);
5452 if (mpz_cmp_ui (index
, INT_MAX
) > 0)
5453 gfc_internal_error ("Reshaped array too large at %C");
5455 j
= mpz_get_ui (index
);
5458 e
= gfc_constructor_lookup_expr (source
->value
.constructor
, j
);
5468 e
= gfc_constructor_lookup_expr (pad
->value
.constructor
, j
);
5472 gfc_constructor_append_expr (&result
->value
.constructor
,
5473 gfc_copy_expr (e
), &e
->where
);
5475 /* Calculate the next element. */
5479 if (++x
[i
] < shape
[i
])
5495 gfc_simplify_rrspacing (gfc_expr
*x
)
5501 if (x
->expr_type
!= EXPR_CONSTANT
)
5504 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
5506 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5508 /* RRSPACING(+/- 0.0) = 0.0 */
5509 if (mpfr_zero_p (x
->value
.real
))
5511 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5515 /* RRSPACING(inf) = NaN */
5516 if (mpfr_inf_p (x
->value
.real
))
5518 mpfr_set_nan (result
->value
.real
);
5522 /* RRSPACING(NaN) = same NaN */
5523 if (mpfr_nan_p (x
->value
.real
))
5525 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5529 /* | x * 2**(-e) | * 2**p. */
5530 mpfr_abs (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5531 e
= - (long int) mpfr_get_exp (x
->value
.real
);
5532 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, e
, GFC_RND_MODE
);
5534 p
= (long int) gfc_real_kinds
[i
].digits
;
5535 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, p
, GFC_RND_MODE
);
5537 return range_check (result
, "RRSPACING");
5542 gfc_simplify_scale (gfc_expr
*x
, gfc_expr
*i
)
5544 int k
, neg_flag
, power
, exp_range
;
5545 mpfr_t scale
, radix
;
5548 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5551 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5553 if (mpfr_zero_p (x
->value
.real
))
5555 mpfr_set_ui (result
->value
.real
, 0, GFC_RND_MODE
);
5559 k
= gfc_validate_kind (BT_REAL
, x
->ts
.kind
, false);
5561 exp_range
= gfc_real_kinds
[k
].max_exponent
- gfc_real_kinds
[k
].min_exponent
;
5563 /* This check filters out values of i that would overflow an int. */
5564 if (mpz_cmp_si (i
->value
.integer
, exp_range
+ 2) > 0
5565 || mpz_cmp_si (i
->value
.integer
, -exp_range
- 2) < 0)
5567 gfc_error ("Result of SCALE overflows its kind at %L", &result
->where
);
5568 gfc_free_expr (result
);
5569 return &gfc_bad_expr
;
5572 /* Compute scale = radix ** power. */
5573 power
= mpz_get_si (i
->value
.integer
);
5583 gfc_set_model_kind (x
->ts
.kind
);
5586 mpfr_set_ui (radix
, gfc_real_kinds
[k
].radix
, GFC_RND_MODE
);
5587 mpfr_pow_ui (scale
, radix
, power
, GFC_RND_MODE
);
5590 mpfr_div (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5592 mpfr_mul (result
->value
.real
, x
->value
.real
, scale
, GFC_RND_MODE
);
5594 mpfr_clears (scale
, radix
, NULL
);
5596 return range_check (result
, "SCALE");
5600 /* Variants of strspn and strcspn that operate on wide characters. */
5603 wide_strspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5606 const gfc_char_t
*c
;
5610 for (c
= s2
; *c
; c
++)
5624 wide_strcspn (const gfc_char_t
*s1
, const gfc_char_t
*s2
)
5627 const gfc_char_t
*c
;
5631 for (c
= s2
; *c
; c
++)
5646 gfc_simplify_scan (gfc_expr
*e
, gfc_expr
*c
, gfc_expr
*b
, gfc_expr
*kind
)
5651 size_t indx
, len
, lenc
;
5652 int k
= get_kind (BT_INTEGER
, kind
, "SCAN", gfc_default_integer_kind
);
5655 return &gfc_bad_expr
;
5657 if (e
->expr_type
!= EXPR_CONSTANT
|| c
->expr_type
!= EXPR_CONSTANT
5658 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
5661 if (b
!= NULL
&& b
->value
.logical
!= 0)
5666 len
= e
->value
.character
.length
;
5667 lenc
= c
->value
.character
.length
;
5669 if (len
== 0 || lenc
== 0)
5677 indx
= wide_strcspn (e
->value
.character
.string
,
5678 c
->value
.character
.string
) + 1;
5685 for (indx
= len
; indx
> 0; indx
--)
5687 for (i
= 0; i
< lenc
; i
++)
5689 if (c
->value
.character
.string
[i
]
5690 == e
->value
.character
.string
[indx
- 1])
5699 result
= gfc_get_int_expr (k
, &e
->where
, indx
);
5700 return range_check (result
, "SCAN");
5705 gfc_simplify_selected_char_kind (gfc_expr
*e
)
5709 if (e
->expr_type
!= EXPR_CONSTANT
)
5712 if (gfc_compare_with_Cstring (e
, "ascii", false) == 0
5713 || gfc_compare_with_Cstring (e
, "default", false) == 0)
5715 else if (gfc_compare_with_Cstring (e
, "iso_10646", false) == 0)
5720 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5725 gfc_simplify_selected_int_kind (gfc_expr
*e
)
5729 if (e
->expr_type
!= EXPR_CONSTANT
|| gfc_extract_int (e
, &range
))
5734 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
5735 if (gfc_integer_kinds
[i
].range
>= range
5736 && gfc_integer_kinds
[i
].kind
< kind
)
5737 kind
= gfc_integer_kinds
[i
].kind
;
5739 if (kind
== INT_MAX
)
5742 return gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, kind
);
5747 gfc_simplify_selected_real_kind (gfc_expr
*p
, gfc_expr
*q
, gfc_expr
*rdx
)
5749 int range
, precision
, radix
, i
, kind
, found_precision
, found_range
,
5751 locus
*loc
= &gfc_current_locus
;
5757 if (p
->expr_type
!= EXPR_CONSTANT
5758 || gfc_extract_int (p
, &precision
))
5767 if (q
->expr_type
!= EXPR_CONSTANT
5768 || gfc_extract_int (q
, &range
))
5779 if (rdx
->expr_type
!= EXPR_CONSTANT
5780 || gfc_extract_int (rdx
, &radix
))
5788 found_precision
= 0;
5792 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
5794 if (gfc_real_kinds
[i
].precision
>= precision
)
5795 found_precision
= 1;
5797 if (gfc_real_kinds
[i
].range
>= range
)
5800 if (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5803 if (gfc_real_kinds
[i
].precision
>= precision
5804 && gfc_real_kinds
[i
].range
>= range
5805 && (radix
== 0 || gfc_real_kinds
[i
].radix
== radix
)
5806 && gfc_real_kinds
[i
].kind
< kind
)
5807 kind
= gfc_real_kinds
[i
].kind
;
5810 if (kind
== INT_MAX
)
5812 if (found_radix
&& found_range
&& !found_precision
)
5814 else if (found_radix
&& found_precision
&& !found_range
)
5816 else if (found_radix
&& !found_precision
&& !found_range
)
5818 else if (found_radix
)
5824 return gfc_get_int_expr (gfc_default_integer_kind
, loc
, kind
);
5829 gfc_simplify_set_exponent (gfc_expr
*x
, gfc_expr
*i
)
5832 mpfr_t exp
, absv
, log2
, pow2
, frac
;
5835 if (x
->expr_type
!= EXPR_CONSTANT
|| i
->expr_type
!= EXPR_CONSTANT
)
5838 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
5840 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
5841 SET_EXPONENT (NaN) = same NaN */
5842 if (mpfr_zero_p (x
->value
.real
) || mpfr_nan_p (x
->value
.real
))
5844 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
5848 /* SET_EXPONENT (inf) = NaN */
5849 if (mpfr_inf_p (x
->value
.real
))
5851 mpfr_set_nan (result
->value
.real
);
5855 gfc_set_model_kind (x
->ts
.kind
);
5862 mpfr_abs (absv
, x
->value
.real
, GFC_RND_MODE
);
5863 mpfr_log2 (log2
, absv
, GFC_RND_MODE
);
5865 mpfr_trunc (log2
, log2
);
5866 mpfr_add_ui (exp
, log2
, 1, GFC_RND_MODE
);
5868 /* Old exponent value, and fraction. */
5869 mpfr_ui_pow (pow2
, 2, exp
, GFC_RND_MODE
);
5871 mpfr_div (frac
, absv
, pow2
, GFC_RND_MODE
);
5874 exp2
= (unsigned long) mpz_get_d (i
->value
.integer
);
5875 mpfr_mul_2exp (result
->value
.real
, frac
, exp2
, GFC_RND_MODE
);
5877 mpfr_clears (absv
, log2
, pow2
, frac
, NULL
);
5879 return range_check (result
, "SET_EXPONENT");
5884 gfc_simplify_shape (gfc_expr
*source
, gfc_expr
*kind
)
5886 mpz_t shape
[GFC_MAX_DIMENSIONS
];
5887 gfc_expr
*result
, *e
, *f
;
5891 int k
= get_kind (BT_INTEGER
, kind
, "SHAPE", gfc_default_integer_kind
);
5893 if (source
->rank
== -1)
5896 result
= gfc_get_array_expr (BT_INTEGER
, k
, &source
->where
);
5898 if (source
->rank
== 0)
5901 if (source
->expr_type
== EXPR_VARIABLE
)
5903 ar
= gfc_find_array_ref (source
);
5904 t
= gfc_array_ref_shape (ar
, shape
);
5906 else if (source
->shape
)
5909 for (n
= 0; n
< source
->rank
; n
++)
5911 mpz_init (shape
[n
]);
5912 mpz_set (shape
[n
], source
->shape
[n
]);
5918 for (n
= 0; n
< source
->rank
; n
++)
5920 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &source
->where
);
5923 mpz_set (e
->value
.integer
, shape
[n
]);
5926 mpz_set_ui (e
->value
.integer
, n
+ 1);
5928 f
= simplify_size (source
, e
, k
);
5932 gfc_free_expr (result
);
5939 if (e
== &gfc_bad_expr
|| range_check (e
, "SHAPE") == &gfc_bad_expr
)
5941 gfc_free_expr (result
);
5943 gfc_clear_shape (shape
, source
->rank
);
5944 return &gfc_bad_expr
;
5947 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
5951 gfc_clear_shape (shape
, source
->rank
);
5958 simplify_size (gfc_expr
*array
, gfc_expr
*dim
, int k
)
5961 gfc_expr
*return_value
;
5964 /* For unary operations, the size of the result is given by the size
5965 of the operand. For binary ones, it's the size of the first operand
5966 unless it is scalar, then it is the size of the second. */
5967 if (array
->expr_type
== EXPR_OP
&& !array
->value
.op
.uop
)
5969 gfc_expr
* replacement
;
5970 gfc_expr
* simplified
;
5972 switch (array
->value
.op
.op
)
5974 /* Unary operations. */
5976 case INTRINSIC_UPLUS
:
5977 case INTRINSIC_UMINUS
:
5978 case INTRINSIC_PARENTHESES
:
5979 replacement
= array
->value
.op
.op1
;
5982 /* Binary operations. If any one of the operands is scalar, take
5983 the other one's size. If both of them are arrays, it does not
5984 matter -- try to find one with known shape, if possible. */
5986 if (array
->value
.op
.op1
->rank
== 0)
5987 replacement
= array
->value
.op
.op2
;
5988 else if (array
->value
.op
.op2
->rank
== 0)
5989 replacement
= array
->value
.op
.op1
;
5992 simplified
= simplify_size (array
->value
.op
.op1
, dim
, k
);
5996 replacement
= array
->value
.op
.op2
;
6001 /* Try to reduce it directly if possible. */
6002 simplified
= simplify_size (replacement
, dim
, k
);
6004 /* Otherwise, we build a new SIZE call. This is hopefully at least
6005 simpler than the original one. */
6008 gfc_expr
*kind
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, k
);
6009 simplified
= gfc_build_intrinsic_call (gfc_current_ns
,
6010 GFC_ISYM_SIZE
, "size",
6012 gfc_copy_expr (replacement
),
6013 gfc_copy_expr (dim
),
6021 if (!gfc_array_size (array
, &size
))
6026 if (dim
->expr_type
!= EXPR_CONSTANT
)
6029 d
= mpz_get_ui (dim
->value
.integer
) - 1;
6030 if (!gfc_array_dimen_size (array
, d
, &size
))
6034 return_value
= gfc_get_constant_expr (BT_INTEGER
, k
, &array
->where
);
6035 mpz_set (return_value
->value
.integer
, size
);
6038 return return_value
;
6043 gfc_simplify_size (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6046 int k
= get_kind (BT_INTEGER
, kind
, "SIZE", gfc_default_integer_kind
);
6049 return &gfc_bad_expr
;
6051 result
= simplify_size (array
, dim
, k
);
6052 if (result
== NULL
|| result
== &gfc_bad_expr
)
6055 return range_check (result
, "SIZE");
6059 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
6060 multiplied by the array size. */
6063 gfc_simplify_sizeof (gfc_expr
*x
)
6065 gfc_expr
*result
= NULL
;
6068 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
6071 if (x
->ts
.type
== BT_CHARACTER
6072 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
6073 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
6076 if (x
->rank
&& x
->expr_type
!= EXPR_ARRAY
6077 && !gfc_array_size (x
, &array_size
))
6080 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
6082 mpz_set_si (result
->value
.integer
, gfc_target_expr_size (x
));
6088 /* STORAGE_SIZE returns the size in bits of a single array element. */
6091 gfc_simplify_storage_size (gfc_expr
*x
,
6094 gfc_expr
*result
= NULL
;
6097 if (x
->ts
.type
== BT_CLASS
|| x
->ts
.deferred
)
6100 if (x
->ts
.type
== BT_CHARACTER
&& x
->expr_type
!= EXPR_CONSTANT
6101 && (!x
->ts
.u
.cl
|| !x
->ts
.u
.cl
->length
6102 || x
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
6105 k
= get_kind (BT_INTEGER
, kind
, "STORAGE_SIZE", gfc_default_integer_kind
);
6107 return &gfc_bad_expr
;
6109 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &x
->where
);
6111 mpz_set_si (result
->value
.integer
, gfc_element_size (x
));
6112 mpz_mul_ui (result
->value
.integer
, result
->value
.integer
, BITS_PER_UNIT
);
6114 return range_check (result
, "STORAGE_SIZE");
6119 gfc_simplify_sign (gfc_expr
*x
, gfc_expr
*y
)
6123 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
6126 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6131 mpz_abs (result
->value
.integer
, x
->value
.integer
);
6132 if (mpz_sgn (y
->value
.integer
) < 0)
6133 mpz_neg (result
->value
.integer
, result
->value
.integer
);
6138 mpfr_copysign (result
->value
.real
, x
->value
.real
, y
->value
.real
,
6141 mpfr_setsign (result
->value
.real
, x
->value
.real
,
6142 mpfr_sgn (y
->value
.real
) < 0 ? 1 : 0, GFC_RND_MODE
);
6146 gfc_internal_error ("Bad type in gfc_simplify_sign");
6154 gfc_simplify_sin (gfc_expr
*x
)
6158 if (x
->expr_type
!= EXPR_CONSTANT
)
6161 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6166 mpfr_sin (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6170 gfc_set_model (x
->value
.real
);
6171 mpc_sin (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6175 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
6178 return range_check (result
, "SIN");
6183 gfc_simplify_sinh (gfc_expr
*x
)
6187 if (x
->expr_type
!= EXPR_CONSTANT
)
6190 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6195 mpfr_sinh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6199 mpc_sinh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6206 return range_check (result
, "SINH");
6210 /* The argument is always a double precision real that is converted to
6211 single precision. TODO: Rounding! */
6214 gfc_simplify_sngl (gfc_expr
*a
)
6218 if (a
->expr_type
!= EXPR_CONSTANT
)
6221 result
= gfc_real2real (a
, gfc_default_real_kind
);
6222 return range_check (result
, "SNGL");
6227 gfc_simplify_spacing (gfc_expr
*x
)
6233 if (x
->expr_type
!= EXPR_CONSTANT
)
6236 i
= gfc_validate_kind (x
->ts
.type
, x
->ts
.kind
, false);
6237 result
= gfc_get_constant_expr (BT_REAL
, x
->ts
.kind
, &x
->where
);
6239 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
6240 if (mpfr_zero_p (x
->value
.real
))
6242 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6246 /* SPACING(inf) = NaN */
6247 if (mpfr_inf_p (x
->value
.real
))
6249 mpfr_set_nan (result
->value
.real
);
6253 /* SPACING(NaN) = same NaN */
6254 if (mpfr_nan_p (x
->value
.real
))
6256 mpfr_set (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6260 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
6261 are the radix, exponent of x, and precision. This excludes the
6262 possibility of subnormal numbers. Fortran 2003 states the result is
6263 b**max(e - p, emin - 1). */
6265 ep
= (long int) mpfr_get_exp (x
->value
.real
) - gfc_real_kinds
[i
].digits
;
6266 en
= (long int) gfc_real_kinds
[i
].min_exponent
- 1;
6267 en
= en
> ep
? en
: ep
;
6269 mpfr_set_ui (result
->value
.real
, 1, GFC_RND_MODE
);
6270 mpfr_mul_2si (result
->value
.real
, result
->value
.real
, en
, GFC_RND_MODE
);
6272 return range_check (result
, "SPACING");
6277 gfc_simplify_spread (gfc_expr
*source
, gfc_expr
*dim_expr
, gfc_expr
*ncopies_expr
)
6279 gfc_expr
*result
= NULL
;
6280 int nelem
, i
, j
, dim
, ncopies
;
6283 if ((!gfc_is_constant_expr (source
)
6284 && !is_constant_array_expr (source
))
6285 || !gfc_is_constant_expr (dim_expr
)
6286 || !gfc_is_constant_expr (ncopies_expr
))
6289 gcc_assert (dim_expr
->ts
.type
== BT_INTEGER
);
6290 gfc_extract_int (dim_expr
, &dim
);
6291 dim
-= 1; /* zero-base DIM */
6293 gcc_assert (ncopies_expr
->ts
.type
== BT_INTEGER
);
6294 gfc_extract_int (ncopies_expr
, &ncopies
);
6295 ncopies
= MAX (ncopies
, 0);
6297 /* Do not allow the array size to exceed the limit for an array
6299 if (source
->expr_type
== EXPR_ARRAY
)
6301 if (!gfc_array_size (source
, &size
))
6302 gfc_internal_error ("Failure getting length of a constant array.");
6305 mpz_init_set_ui (size
, 1);
6307 nelem
= mpz_get_si (size
) * ncopies
;
6308 if (nelem
> flag_max_array_constructor
)
6310 if (gfc_current_ns
->sym_root
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
6312 gfc_error ("The number of elements (%d) in the array constructor "
6313 "at %L requires an increase of the allowed %d upper "
6314 "limit. See %<-fmax-array-constructor%> option.",
6315 nelem
, &source
->where
, flag_max_array_constructor
);
6316 return &gfc_bad_expr
;
6322 if (source
->expr_type
== EXPR_CONSTANT
)
6324 gcc_assert (dim
== 0);
6326 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6328 if (source
->ts
.type
== BT_DERIVED
)
6329 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6331 result
->shape
= gfc_get_shape (result
->rank
);
6332 mpz_init_set_si (result
->shape
[0], ncopies
);
6334 for (i
= 0; i
< ncopies
; ++i
)
6335 gfc_constructor_append_expr (&result
->value
.constructor
,
6336 gfc_copy_expr (source
), NULL
);
6338 else if (source
->expr_type
== EXPR_ARRAY
)
6340 int offset
, rstride
[GFC_MAX_DIMENSIONS
], extent
[GFC_MAX_DIMENSIONS
];
6341 gfc_constructor
*source_ctor
;
6343 gcc_assert (source
->rank
< GFC_MAX_DIMENSIONS
);
6344 gcc_assert (dim
>= 0 && dim
<= source
->rank
);
6346 result
= gfc_get_array_expr (source
->ts
.type
, source
->ts
.kind
,
6348 if (source
->ts
.type
== BT_DERIVED
)
6349 result
->ts
.u
.derived
= source
->ts
.u
.derived
;
6350 result
->rank
= source
->rank
+ 1;
6351 result
->shape
= gfc_get_shape (result
->rank
);
6353 for (i
= 0, j
= 0; i
< result
->rank
; ++i
)
6356 mpz_init_set (result
->shape
[i
], source
->shape
[j
++]);
6358 mpz_init_set_si (result
->shape
[i
], ncopies
);
6360 extent
[i
] = mpz_get_si (result
->shape
[i
]);
6361 rstride
[i
] = (i
== 0) ? 1 : rstride
[i
-1] * extent
[i
-1];
6365 for (source_ctor
= gfc_constructor_first (source
->value
.constructor
);
6366 source_ctor
; source_ctor
= gfc_constructor_next (source_ctor
))
6368 for (i
= 0; i
< ncopies
; ++i
)
6369 gfc_constructor_insert_expr (&result
->value
.constructor
,
6370 gfc_copy_expr (source_ctor
->expr
),
6371 NULL
, offset
+ i
* rstride
[dim
]);
6373 offset
+= (dim
== 0 ? ncopies
: 1);
6378 gfc_error ("Simplification of SPREAD at %C not yet implemented");
6379 return &gfc_bad_expr
;
6382 if (source
->ts
.type
== BT_CHARACTER
)
6383 result
->ts
.u
.cl
= source
->ts
.u
.cl
;
6390 gfc_simplify_sqrt (gfc_expr
*e
)
6392 gfc_expr
*result
= NULL
;
6394 if (e
->expr_type
!= EXPR_CONSTANT
)
6400 if (mpfr_cmp_si (e
->value
.real
, 0) < 0)
6402 gfc_error ("Argument of SQRT at %L has a negative value",
6404 return &gfc_bad_expr
;
6406 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6407 mpfr_sqrt (result
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
6411 gfc_set_model (e
->value
.real
);
6413 result
= gfc_get_constant_expr (e
->ts
.type
, e
->ts
.kind
, &e
->where
);
6414 mpc_sqrt (result
->value
.complex, e
->value
.complex, GFC_MPC_RND_MODE
);
6418 gfc_internal_error ("invalid argument of SQRT at %L", &e
->where
);
6421 return range_check (result
, "SQRT");
6426 gfc_simplify_sum (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*mask
)
6428 return simplify_transformation (array
, dim
, mask
, 0, gfc_add
);
6433 gfc_simplify_cotan (gfc_expr
*x
)
6438 if (x
->expr_type
!= EXPR_CONSTANT
)
6441 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6446 mpfr_cot (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6450 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
6451 val
= &result
->value
.complex;
6452 mpc_init2 (swp
, mpfr_get_default_prec ());
6453 mpc_cos (swp
, x
->value
.complex, GFC_MPC_RND_MODE
);
6454 mpc_sin (*val
, x
->value
.complex, GFC_MPC_RND_MODE
);
6455 mpc_div (*val
, swp
, *val
, GFC_MPC_RND_MODE
);
6463 return range_check (result
, "COTAN");
6468 gfc_simplify_tan (gfc_expr
*x
)
6472 if (x
->expr_type
!= EXPR_CONSTANT
)
6475 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6480 mpfr_tan (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6484 mpc_tan (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6491 return range_check (result
, "TAN");
6496 gfc_simplify_tanh (gfc_expr
*x
)
6500 if (x
->expr_type
!= EXPR_CONSTANT
)
6503 result
= gfc_get_constant_expr (x
->ts
.type
, x
->ts
.kind
, &x
->where
);
6508 mpfr_tanh (result
->value
.real
, x
->value
.real
, GFC_RND_MODE
);
6512 mpc_tanh (result
->value
.complex, x
->value
.complex, GFC_MPC_RND_MODE
);
6519 return range_check (result
, "TANH");
6524 gfc_simplify_tiny (gfc_expr
*e
)
6529 i
= gfc_validate_kind (BT_REAL
, e
->ts
.kind
, false);
6531 result
= gfc_get_constant_expr (BT_REAL
, e
->ts
.kind
, &e
->where
);
6532 mpfr_set (result
->value
.real
, gfc_real_kinds
[i
].tiny
, GFC_RND_MODE
);
6539 gfc_simplify_trailz (gfc_expr
*e
)
6541 unsigned long tz
, bs
;
6544 if (e
->expr_type
!= EXPR_CONSTANT
)
6547 i
= gfc_validate_kind (e
->ts
.type
, e
->ts
.kind
, false);
6548 bs
= gfc_integer_kinds
[i
].bit_size
;
6549 tz
= mpz_scan1 (e
->value
.integer
, 0);
6551 return gfc_get_int_expr (gfc_default_integer_kind
,
6552 &e
->where
, MIN (tz
, bs
));
6557 gfc_simplify_transfer (gfc_expr
*source
, gfc_expr
*mold
, gfc_expr
*size
)
6560 gfc_expr
*mold_element
;
6565 unsigned char *buffer
;
6566 size_t result_length
;
6569 if (!gfc_is_constant_expr (source
)
6570 || (gfc_init_expr_flag
&& !gfc_is_constant_expr (mold
))
6571 || !gfc_is_constant_expr (size
))
6574 if (!gfc_calculate_transfer_sizes (source
, mold
, size
, &source_size
,
6575 &result_size
, &result_length
))
6578 /* Calculate the size of the source. */
6579 if (source
->expr_type
== EXPR_ARRAY
&& !gfc_array_size (source
, &tmp
))
6580 gfc_internal_error ("Failure getting length of a constant array.");
6582 /* Create an empty new expression with the appropriate characteristics. */
6583 result
= gfc_get_constant_expr (mold
->ts
.type
, mold
->ts
.kind
,
6585 result
->ts
= mold
->ts
;
6587 mold_element
= (mold
->expr_type
== EXPR_ARRAY
&& mold
->value
.constructor
)
6588 ? gfc_constructor_first (mold
->value
.constructor
)->expr
6591 /* Set result character length, if needed. Note that this needs to be
6592 set even for array expressions, in order to pass this information into
6593 gfc_target_interpret_expr. */
6594 if (result
->ts
.type
== BT_CHARACTER
&& gfc_is_constant_expr (mold_element
))
6595 result
->value
.character
.length
= mold_element
->value
.character
.length
;
6597 /* Set the number of elements in the result, and determine its size. */
6599 if (mold
->expr_type
== EXPR_ARRAY
|| mold
->rank
|| size
)
6601 result
->expr_type
= EXPR_ARRAY
;
6603 result
->shape
= gfc_get_shape (1);
6604 mpz_init_set_ui (result
->shape
[0], result_length
);
6609 /* Allocate the buffer to store the binary version of the source. */
6610 buffer_size
= MAX (source_size
, result_size
);
6611 buffer
= (unsigned char*)alloca (buffer_size
);
6612 memset (buffer
, 0, buffer_size
);
6614 /* Now write source to the buffer. */
6615 gfc_target_encode_expr (source
, buffer
, buffer_size
);
6617 /* And read the buffer back into the new expression. */
6618 gfc_target_interpret_expr (buffer
, buffer_size
, result
, false);
6625 gfc_simplify_transpose (gfc_expr
*matrix
)
6627 int row
, matrix_rows
, col
, matrix_cols
;
6630 if (!is_constant_array_expr (matrix
))
6633 gcc_assert (matrix
->rank
== 2);
6635 result
= gfc_get_array_expr (matrix
->ts
.type
, matrix
->ts
.kind
,
6638 result
->shape
= gfc_get_shape (result
->rank
);
6639 mpz_set (result
->shape
[0], matrix
->shape
[1]);
6640 mpz_set (result
->shape
[1], matrix
->shape
[0]);
6642 if (matrix
->ts
.type
== BT_CHARACTER
)
6643 result
->ts
.u
.cl
= matrix
->ts
.u
.cl
;
6644 else if (matrix
->ts
.type
== BT_DERIVED
)
6645 result
->ts
.u
.derived
= matrix
->ts
.u
.derived
;
6647 matrix_rows
= mpz_get_si (matrix
->shape
[0]);
6648 matrix_cols
= mpz_get_si (matrix
->shape
[1]);
6649 for (row
= 0; row
< matrix_rows
; ++row
)
6650 for (col
= 0; col
< matrix_cols
; ++col
)
6652 gfc_expr
*e
= gfc_constructor_lookup_expr (matrix
->value
.constructor
,
6653 col
* matrix_rows
+ row
);
6654 gfc_constructor_insert_expr (&result
->value
.constructor
,
6655 gfc_copy_expr (e
), &matrix
->where
,
6656 row
* matrix_cols
+ col
);
6664 gfc_simplify_trim (gfc_expr
*e
)
6667 int count
, i
, len
, lentrim
;
6669 if (e
->expr_type
!= EXPR_CONSTANT
)
6672 len
= e
->value
.character
.length
;
6673 for (count
= 0, i
= 1; i
<= len
; ++i
)
6675 if (e
->value
.character
.string
[len
- i
] == ' ')
6681 lentrim
= len
- count
;
6683 result
= gfc_get_character_expr (e
->ts
.kind
, &e
->where
, NULL
, lentrim
);
6684 for (i
= 0; i
< lentrim
; i
++)
6685 result
->value
.character
.string
[i
] = e
->value
.character
.string
[i
];
6692 gfc_simplify_image_index (gfc_expr
*coarray
, gfc_expr
*sub
)
6697 gfc_constructor
*sub_cons
;
6701 if (!is_constant_array_expr (sub
))
6704 /* Follow any component references. */
6705 as
= coarray
->symtree
->n
.sym
->as
;
6706 for (ref
= coarray
->ref
; ref
; ref
= ref
->next
)
6707 if (ref
->type
== REF_COMPONENT
)
6710 if (as
->type
== AS_DEFERRED
)
6713 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6714 the cosubscript addresses the first image. */
6716 sub_cons
= gfc_constructor_first (sub
->value
.constructor
);
6719 for (d
= 1; d
<= as
->corank
; d
++)
6724 gcc_assert (sub_cons
!= NULL
);
6726 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 0, as
,
6728 if (ca_bound
== NULL
)
6731 if (ca_bound
== &gfc_bad_expr
)
6734 cmp
= mpz_cmp (ca_bound
->value
.integer
, sub_cons
->expr
->value
.integer
);
6738 gfc_free_expr (ca_bound
);
6739 sub_cons
= gfc_constructor_next (sub_cons
);
6743 first_image
= false;
6747 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6748 "SUB has %ld and COARRAY lower bound is %ld)",
6750 mpz_get_si (sub_cons
->expr
->value
.integer
),
6751 mpz_get_si (ca_bound
->value
.integer
));
6752 gfc_free_expr (ca_bound
);
6753 return &gfc_bad_expr
;
6756 gfc_free_expr (ca_bound
);
6758 /* Check whether upperbound is valid for the multi-images case. */
6761 ca_bound
= simplify_bound_dim (coarray
, NULL
, d
+ as
->rank
, 1, as
,
6763 if (ca_bound
== &gfc_bad_expr
)
6766 if (ca_bound
&& ca_bound
->expr_type
== EXPR_CONSTANT
6767 && mpz_cmp (ca_bound
->value
.integer
,
6768 sub_cons
->expr
->value
.integer
) < 0)
6770 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6771 "SUB has %ld and COARRAY upper bound is %ld)",
6773 mpz_get_si (sub_cons
->expr
->value
.integer
),
6774 mpz_get_si (ca_bound
->value
.integer
));
6775 gfc_free_expr (ca_bound
);
6776 return &gfc_bad_expr
;
6780 gfc_free_expr (ca_bound
);
6783 sub_cons
= gfc_constructor_next (sub_cons
);
6786 gcc_assert (sub_cons
== NULL
);
6788 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
&& !first_image
)
6791 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6792 &gfc_current_locus
);
6794 mpz_set_si (result
->value
.integer
, 1);
6796 mpz_set_si (result
->value
.integer
, 0);
6802 gfc_simplify_image_status (gfc_expr
*image
, gfc_expr
*team ATTRIBUTE_UNUSED
)
6804 if (flag_coarray
== GFC_FCOARRAY_NONE
)
6806 gfc_current_locus
= *gfc_current_intrinsic_where
;
6807 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6808 return &gfc_bad_expr
;
6811 /* Simplification is possible for fcoarray = single only. For all other modes
6812 the result depends on runtime conditions. */
6813 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6816 if (gfc_is_constant_expr (image
))
6819 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6821 if (mpz_get_si (image
->value
.integer
) == 1)
6822 mpz_set_si (result
->value
.integer
, 0);
6824 mpz_set_si (result
->value
.integer
, GFC_STAT_STOPPED_IMAGE
);
6833 gfc_simplify_this_image (gfc_expr
*coarray
, gfc_expr
*dim
,
6834 gfc_expr
*distance ATTRIBUTE_UNUSED
)
6836 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
)
6839 /* If no coarray argument has been passed or when the first argument
6840 is actually a distance argment. */
6841 if (coarray
== NULL
|| !gfc_is_coarray (coarray
))
6844 /* FIXME: gfc_current_locus is wrong. */
6845 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
6846 &gfc_current_locus
);
6847 mpz_set_si (result
->value
.integer
, 1);
6851 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
6852 return simplify_cobound (coarray
, dim
, NULL
, 0);
6857 gfc_simplify_ubound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6859 return simplify_bound (array
, dim
, kind
, 1);
6863 gfc_simplify_ucobound (gfc_expr
*array
, gfc_expr
*dim
, gfc_expr
*kind
)
6865 return simplify_cobound (array
, dim
, kind
, 1);
6870 gfc_simplify_unpack (gfc_expr
*vector
, gfc_expr
*mask
, gfc_expr
*field
)
6872 gfc_expr
*result
, *e
;
6873 gfc_constructor
*vector_ctor
, *mask_ctor
, *field_ctor
;
6875 if (!is_constant_array_expr (vector
)
6876 || !is_constant_array_expr (mask
)
6877 || (!gfc_is_constant_expr (field
)
6878 && !is_constant_array_expr (field
)))
6881 result
= gfc_get_array_expr (vector
->ts
.type
, vector
->ts
.kind
,
6883 if (vector
->ts
.type
== BT_DERIVED
)
6884 result
->ts
.u
.derived
= vector
->ts
.u
.derived
;
6885 result
->rank
= mask
->rank
;
6886 result
->shape
= gfc_copy_shape (mask
->shape
, mask
->rank
);
6888 if (vector
->ts
.type
== BT_CHARACTER
)
6889 result
->ts
.u
.cl
= vector
->ts
.u
.cl
;
6891 vector_ctor
= gfc_constructor_first (vector
->value
.constructor
);
6892 mask_ctor
= gfc_constructor_first (mask
->value
.constructor
);
6894 = field
->expr_type
== EXPR_ARRAY
6895 ? gfc_constructor_first (field
->value
.constructor
)
6900 if (mask_ctor
->expr
->value
.logical
)
6902 gcc_assert (vector_ctor
);
6903 e
= gfc_copy_expr (vector_ctor
->expr
);
6904 vector_ctor
= gfc_constructor_next (vector_ctor
);
6906 else if (field
->expr_type
== EXPR_ARRAY
)
6907 e
= gfc_copy_expr (field_ctor
->expr
);
6909 e
= gfc_copy_expr (field
);
6911 gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
6913 mask_ctor
= gfc_constructor_next (mask_ctor
);
6914 field_ctor
= gfc_constructor_next (field_ctor
);
6922 gfc_simplify_verify (gfc_expr
*s
, gfc_expr
*set
, gfc_expr
*b
, gfc_expr
*kind
)
6926 size_t index
, len
, lenset
;
6928 int k
= get_kind (BT_INTEGER
, kind
, "VERIFY", gfc_default_integer_kind
);
6931 return &gfc_bad_expr
;
6933 if (s
->expr_type
!= EXPR_CONSTANT
|| set
->expr_type
!= EXPR_CONSTANT
6934 || ( b
!= NULL
&& b
->expr_type
!= EXPR_CONSTANT
))
6937 if (b
!= NULL
&& b
->value
.logical
!= 0)
6942 result
= gfc_get_constant_expr (BT_INTEGER
, k
, &s
->where
);
6944 len
= s
->value
.character
.length
;
6945 lenset
= set
->value
.character
.length
;
6949 mpz_set_ui (result
->value
.integer
, 0);
6957 mpz_set_ui (result
->value
.integer
, 1);
6961 index
= wide_strspn (s
->value
.character
.string
,
6962 set
->value
.character
.string
) + 1;
6971 mpz_set_ui (result
->value
.integer
, len
);
6974 for (index
= len
; index
> 0; index
--)
6976 for (i
= 0; i
< lenset
; i
++)
6978 if (s
->value
.character
.string
[index
- 1]
6979 == set
->value
.character
.string
[i
])
6987 mpz_set_ui (result
->value
.integer
, index
);
6993 gfc_simplify_xor (gfc_expr
*x
, gfc_expr
*y
)
6998 if (x
->expr_type
!= EXPR_CONSTANT
|| y
->expr_type
!= EXPR_CONSTANT
)
7001 kind
= x
->ts
.kind
> y
->ts
.kind
? x
->ts
.kind
: y
->ts
.kind
;
7006 result
= gfc_get_constant_expr (BT_INTEGER
, kind
, &x
->where
);
7007 mpz_xor (result
->value
.integer
, x
->value
.integer
, y
->value
.integer
);
7008 return range_check (result
, "XOR");
7011 return gfc_get_logical_expr (kind
, &x
->where
,
7012 (x
->value
.logical
&& !y
->value
.logical
)
7013 || (!x
->value
.logical
&& y
->value
.logical
));
7021 /****************** Constant simplification *****************/
7023 /* Master function to convert one constant to another. While this is
7024 used as a simplification function, it requires the destination type
7025 and kind information which is supplied by a special case in
7029 gfc_convert_constant (gfc_expr
*e
, bt type
, int kind
)
7031 gfc_expr
*g
, *result
, *(*f
) (gfc_expr
*, int);
7046 f
= gfc_int2complex
;
7066 f
= gfc_real2complex
;
7077 f
= gfc_complex2int
;
7080 f
= gfc_complex2real
;
7083 f
= gfc_complex2complex
;
7109 f
= gfc_hollerith2int
;
7113 f
= gfc_hollerith2real
;
7117 f
= gfc_hollerith2complex
;
7121 f
= gfc_hollerith2character
;
7125 f
= gfc_hollerith2logical
;
7135 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
7140 switch (e
->expr_type
)
7143 result
= f (e
, kind
);
7145 return &gfc_bad_expr
;
7149 if (!gfc_is_constant_expr (e
))
7152 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
7153 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
7154 result
->rank
= e
->rank
;
7156 for (c
= gfc_constructor_first (e
->value
.constructor
);
7157 c
; c
= gfc_constructor_next (c
))
7160 if (c
->iterator
== NULL
)
7161 tmp
= f (c
->expr
, kind
);
7164 g
= gfc_convert_constant (c
->expr
, type
, kind
);
7165 if (g
== &gfc_bad_expr
)
7167 gfc_free_expr (result
);
7175 gfc_free_expr (result
);
7179 gfc_constructor_append_expr (&result
->value
.constructor
,
7193 /* Function for converting character constants. */
7195 gfc_convert_char_constant (gfc_expr
*e
, bt type ATTRIBUTE_UNUSED
, int kind
)
7200 if (!gfc_is_constant_expr (e
))
7203 if (e
->expr_type
== EXPR_CONSTANT
)
7205 /* Simple case of a scalar. */
7206 result
= gfc_get_constant_expr (BT_CHARACTER
, kind
, &e
->where
);
7208 return &gfc_bad_expr
;
7210 result
->value
.character
.length
= e
->value
.character
.length
;
7211 result
->value
.character
.string
7212 = gfc_get_wide_string (e
->value
.character
.length
+ 1);
7213 memcpy (result
->value
.character
.string
, e
->value
.character
.string
,
7214 (e
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
7216 /* Check we only have values representable in the destination kind. */
7217 for (i
= 0; i
< result
->value
.character
.length
; i
++)
7218 if (!gfc_check_character_range (result
->value
.character
.string
[i
],
7221 gfc_error ("Character %qs in string at %L cannot be converted "
7222 "into character kind %d",
7223 gfc_print_wide_char (result
->value
.character
.string
[i
]),
7225 gfc_free_expr (result
);
7226 return &gfc_bad_expr
;
7231 else if (e
->expr_type
== EXPR_ARRAY
)
7233 /* For an array constructor, we convert each constructor element. */
7236 result
= gfc_get_array_expr (type
, kind
, &e
->where
);
7237 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
7238 result
->rank
= e
->rank
;
7239 result
->ts
.u
.cl
= e
->ts
.u
.cl
;
7241 for (c
= gfc_constructor_first (e
->value
.constructor
);
7242 c
; c
= gfc_constructor_next (c
))
7244 gfc_expr
*tmp
= gfc_convert_char_constant (c
->expr
, type
, kind
);
7245 if (tmp
== &gfc_bad_expr
)
7247 gfc_free_expr (result
);
7248 return &gfc_bad_expr
;
7253 gfc_free_expr (result
);
7257 gfc_constructor_append_expr (&result
->value
.constructor
,
7269 gfc_simplify_compiler_options (void)
7274 str
= gfc_get_option_string ();
7275 result
= gfc_get_character_expr (gfc_default_character_kind
,
7276 &gfc_current_locus
, str
, strlen (str
));
7283 gfc_simplify_compiler_version (void)
7288 len
= strlen ("GCC version ") + strlen (version_string
);
7289 buffer
= XALLOCAVEC (char, len
+ 1);
7290 snprintf (buffer
, len
+ 1, "GCC version %s", version_string
);
7291 return gfc_get_character_expr (gfc_default_character_kind
,
7292 &gfc_current_locus
, buffer
, len
);
7295 /* Simplification routines for intrinsics of IEEE modules. */
7298 simplify_ieee_selected_real_kind (gfc_expr
*expr
)
7300 gfc_actual_arglist
*arg
;
7301 gfc_expr
*p
= NULL
, *q
= NULL
, *rdx
= NULL
;
7303 arg
= expr
->value
.function
.actual
;
7307 q
= arg
->next
->expr
;
7308 if (arg
->next
->next
)
7309 rdx
= arg
->next
->next
->expr
;
7312 /* Currently, if IEEE is supported and this module is built, it means
7313 all our floating-point types conform to IEEE. Hence, we simply handle
7314 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
7315 return gfc_simplify_selected_real_kind (p
, q
, rdx
);
7319 simplify_ieee_support (gfc_expr
*expr
)
7321 /* We consider that if the IEEE modules are loaded, we have full support
7322 for flags, halting and rounding, which are the three functions
7323 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
7324 expressions. One day, we will need libgfortran to detect support and
7325 communicate it back to us, allowing for partial support. */
7327 return gfc_get_logical_expr (gfc_default_logical_kind
, &expr
->where
,
7332 matches_ieee_function_name (gfc_symbol
*sym
, const char *name
)
7334 int n
= strlen(name
);
7336 if (!strncmp(sym
->name
, name
, n
))
7339 /* If a generic was used and renamed, we need more work to find out.
7340 Compare the specific name. */
7341 if (sym
->generic
&& !strncmp(sym
->generic
->sym
->name
, name
, n
))
7348 gfc_simplify_ieee_functions (gfc_expr
*expr
)
7350 gfc_symbol
* sym
= expr
->symtree
->n
.sym
;
7352 if (matches_ieee_function_name(sym
, "ieee_selected_real_kind"))
7353 return simplify_ieee_selected_real_kind (expr
);
7354 else if (matches_ieee_function_name(sym
, "ieee_support_flag")
7355 || matches_ieee_function_name(sym
, "ieee_support_halting")
7356 || matches_ieee_function_name(sym
, "ieee_support_rounding"))
7357 return simplify_ieee_support (expr
);