1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
3 2010 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
27 #include "intrinsic.h"
28 #include "target-memory.h"
29 #include "constructor.h"
32 gfc_expr gfc_bad_expr;
35 /* Note that 'simplification' is not just transforming expressions.
36 For functions that are not simplified at compile time, range
37 checking is done if possible.
39 The return convention is that each simplification function returns:
41 A new expression node corresponding to the simplified arguments.
42 The original arguments are destroyed by the caller, and must not
43 be a part of the new expression.
45 NULL pointer indicating that no simplification was possible and
46 the original expression should remain intact.
48 An expression pointer to gfc_bad_expr (a static placeholder)
49 indicating that some error has prevented simplification. The
50 error is generated within the function and should be propagated
53 By the time a simplification function gets control, it has been
54 decided that the function call is really supposed to be the
55 intrinsic. No type checking is strictly necessary, since only
56 valid types will be passed on. On the other hand, a simplification
57 subroutine may have to look at the type of an argument as part of
60 Array arguments are only passed to these subroutines that implement
61 the simplification of transformational intrinsics.
63 The functions in this file don't have much comment with them, but
64 everything is reasonably straight-forward. The Standard, chapter 13
65 is the best comment you'll find for this file anyway. */
67 /* Range checks an expression node. If all goes well, returns the
68 node, otherwise returns &gfc_bad_expr and frees the node. */
71 range_check (gfc_expr *result, const char *name)
76 if (result->expr_type != EXPR_CONSTANT)
79 switch (gfc_range_check (result))
85 gfc_error ("Result of %s overflows its kind at %L", name,
90 gfc_error ("Result of %s underflows its kind at %L", name,
95 gfc_error ("Result of %s is NaN at %L", name, &result->where);
99 gfc_error ("Result of %s gives range error for its kind at %L", name,
104 gfc_free_expr (result);
105 return &gfc_bad_expr;
109 /* A helper function that gets an optional and possibly missing
110 kind parameter. Returns the kind, -1 if something went wrong. */
113 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
120 if (k->expr_type != EXPR_CONSTANT)
122 gfc_error ("KIND parameter of %s at %L must be an initialization "
123 "expression", name, &k->where);
127 if (gfc_extract_int (k, &kind) != NULL
128 || gfc_validate_kind (type, kind, true) < 0)
130 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
138 /* Converts an mpz_t signed variable into an unsigned one, assuming
139 two's complement representations and a binary width of bitsize.
140 The conversion is a no-op unless x is negative; otherwise, it can
141 be accomplished by masking out the high bits. */
144 convert_mpz_to_unsigned (mpz_t x, int bitsize)
150 /* Confirm that no bits above the signed range are unset. */
151 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
153 mpz_init_set_ui (mask, 1);
154 mpz_mul_2exp (mask, mask, bitsize);
155 mpz_sub_ui (mask, mask, 1);
157 mpz_and (x, x, mask);
163 /* Confirm that no bits above the signed range are set. */
164 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
169 /* Converts an mpz_t unsigned variable into a signed one, assuming
170 two's complement representations and a binary width of bitsize.
171 If the bitsize-1 bit is set, this is taken as a sign bit and
172 the number is converted to the corresponding negative number. */
175 convert_mpz_to_signed (mpz_t x, int bitsize)
179 /* Confirm that no bits above the unsigned range are set. */
180 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
182 if (mpz_tstbit (x, bitsize - 1) == 1)
184 mpz_init_set_ui (mask, 1);
185 mpz_mul_2exp (mask, mask, bitsize);
186 mpz_sub_ui (mask, mask, 1);
188 /* We negate the number by hand, zeroing the high bits, that is
189 make it the corresponding positive number, and then have it
190 negated by GMP, giving the correct representation of the
193 mpz_add_ui (x, x, 1);
194 mpz_and (x, x, mask);
203 /* In-place convert BOZ to REAL of the specified kind. */
206 convert_boz (gfc_expr *x, int kind)
208 if (x && x->ts.type == BT_INTEGER && x->is_boz)
215 if (!gfc_convert_boz (x, &ts))
216 return &gfc_bad_expr;
223 /* Test that the expression is an constant array. */
226 is_constant_array_expr (gfc_expr *e)
233 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
236 for (c = gfc_constructor_first (e->value.constructor);
237 c; c = gfc_constructor_next (c))
238 if (c->expr->expr_type != EXPR_CONSTANT)
245 /* Initialize a transformational result expression with a given value. */
248 init_result_expr (gfc_expr *e, int init, gfc_expr *array)
250 if (e && e->expr_type == EXPR_ARRAY)
252 gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
255 init_result_expr (ctor->expr, init, array);
256 ctor = gfc_constructor_next (ctor);
259 else if (e && e->expr_type == EXPR_CONSTANT)
261 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
268 e->value.logical = (init ? 1 : 0);
273 mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
274 else if (init == INT_MAX)
275 mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
277 mpz_set_si (e->value.integer, init);
283 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
284 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
286 else if (init == INT_MAX)
287 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
289 mpfr_set_si (e->value.real, init, GFC_RND_MODE);
293 mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
299 gfc_expr *len = gfc_simplify_len (array, NULL);
300 gfc_extract_int (len, &length);
301 string = gfc_get_wide_string (length + 1);
302 gfc_wide_memset (string, 0, length);
304 else if (init == INT_MAX)
306 gfc_expr *len = gfc_simplify_len (array, NULL);
307 gfc_extract_int (len, &length);
308 string = gfc_get_wide_string (length + 1);
309 gfc_wide_memset (string, 255, length);
314 string = gfc_get_wide_string (1);
317 string[length] = '\0';
318 e->value.character.length = length;
319 e->value.character.string = string;
331 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */
334 compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
335 gfc_expr *matrix_b, int stride_b, int offset_b)
337 gfc_expr *result, *a, *b;
339 result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind,
341 init_result_expr (result, 0, NULL);
343 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
344 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
347 /* Copying of expressions is required as operands are free'd
348 by the gfc_arith routines. */
349 switch (result->ts.type)
352 result = gfc_or (result,
353 gfc_and (gfc_copy_expr (a),
360 result = gfc_add (result,
361 gfc_multiply (gfc_copy_expr (a),
369 offset_a += stride_a;
370 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
372 offset_b += stride_b;
373 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
380 /* Build a result expression for transformational intrinsics,
384 transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
385 int kind, locus* where)
390 if (!dim || array->rank == 1)
391 return gfc_get_constant_expr (type, kind, where);
393 result = gfc_get_array_expr (type, kind, where);
394 result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
395 result->rank = array->rank - 1;
397 /* gfc_array_size() would count the number of elements in the constructor,
398 we have not built those yet. */
400 for (i = 0; i < result->rank; ++i)
401 nelem *= mpz_get_ui (result->shape[i]);
403 for (i = 0; i < nelem; ++i)
405 gfc_constructor_append_expr (&result->value.constructor,
406 gfc_get_constant_expr (type, kind, where),
414 typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
416 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
417 of COUNT intrinsic is .TRUE..
419 Interface and implimentation mimics arith functions as
420 gfc_add, gfc_multiply, etc. */
422 static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2)
426 gcc_assert (op1->ts.type == BT_INTEGER);
427 gcc_assert (op2->ts.type == BT_LOGICAL);
428 gcc_assert (op2->value.logical);
430 result = gfc_copy_expr (op1);
431 mpz_add_ui (result->value.integer, result->value.integer, 1);
439 /* Transforms an ARRAY with operation OP, according to MASK, to a
440 scalar RESULT. E.g. called if
442 REAL, PARAMETER :: array(n, m) = ...
443 REAL, PARAMETER :: s = SUM(array)
445 where OP == gfc_add(). */
448 simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
449 transformational_op op)
452 gfc_constructor *array_ctor, *mask_ctor;
454 /* Shortcut for constant .FALSE. MASK. */
456 && mask->expr_type == EXPR_CONSTANT
457 && !mask->value.logical)
460 array_ctor = gfc_constructor_first (array->value.constructor);
462 if (mask && mask->expr_type == EXPR_ARRAY)
463 mask_ctor = gfc_constructor_first (mask->value.constructor);
467 a = array_ctor->expr;
468 array_ctor = gfc_constructor_next (array_ctor);
470 /* A constant MASK equals .TRUE. here and can be ignored. */
474 mask_ctor = gfc_constructor_next (mask_ctor);
475 if (!m->value.logical)
479 result = op (result, gfc_copy_expr (a));
485 /* Transforms an ARRAY with operation OP, according to MASK, to an
486 array RESULT. E.g. called if
488 REAL, PARAMETER :: array(n, m) = ...
489 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
491 where OP == gfc_multiply(). */
494 simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
495 gfc_expr *mask, transformational_op op)
498 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
499 gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
500 gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
502 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
503 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
504 tmpstride[GFC_MAX_DIMENSIONS];
506 /* Shortcut for constant .FALSE. MASK. */
508 && mask->expr_type == EXPR_CONSTANT
509 && !mask->value.logical)
512 /* Build an indexed table for array element expressions to minimize
513 linked-list traversal. Masked elements are set to NULL. */
514 gfc_array_size (array, &size);
515 arraysize = mpz_get_ui (size);
517 arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
519 array_ctor = gfc_constructor_first (array->value.constructor);
521 if (mask && mask->expr_type == EXPR_ARRAY)
522 mask_ctor = gfc_constructor_first (mask->value.constructor);
524 for (i = 0; i < arraysize; ++i)
526 arrayvec[i] = array_ctor->expr;
527 array_ctor = gfc_constructor_next (array_ctor);
531 if (!mask_ctor->expr->value.logical)
534 mask_ctor = gfc_constructor_next (mask_ctor);
538 /* Same for the result expression. */
539 gfc_array_size (result, &size);
540 resultsize = mpz_get_ui (size);
543 resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
544 result_ctor = gfc_constructor_first (result->value.constructor);
545 for (i = 0; i < resultsize; ++i)
547 resultvec[i] = result_ctor->expr;
548 result_ctor = gfc_constructor_next (result_ctor);
551 gfc_extract_int (dim, &dim_index);
552 dim_index -= 1; /* zero-base index */
556 for (i = 0, n = 0; i < array->rank; ++i)
559 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
562 dim_extent = mpz_get_si (array->shape[i]);
563 dim_stride = tmpstride[i];
567 extent[n] = mpz_get_si (array->shape[i]);
568 sstride[n] = tmpstride[i];
569 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
578 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
580 *dest = op (*dest, gfc_copy_expr (*src));
587 while (!done && count[n] == extent[n])
590 base -= sstride[n] * extent[n];
591 dest -= dstride[n] * extent[n];
594 if (n < result->rank)
605 /* Place updated expression in result constructor. */
606 result_ctor = gfc_constructor_first (result->value.constructor);
607 for (i = 0; i < resultsize; ++i)
609 result_ctor->expr = resultvec[i];
610 result_ctor = gfc_constructor_next (result_ctor);
614 gfc_free (resultvec);
620 /********************** Simplification functions *****************************/
623 gfc_simplify_abs (gfc_expr *e)
627 if (e->expr_type != EXPR_CONSTANT)
633 result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
634 mpz_abs (result->value.integer, e->value.integer);
635 return range_check (result, "IABS");
638 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
639 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
640 return range_check (result, "ABS");
643 gfc_set_model_kind (e->ts.kind);
644 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
645 mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
646 return range_check (result, "CABS");
649 gfc_internal_error ("gfc_simplify_abs(): Bad type");
655 simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
659 bool too_large = false;
661 if (e->expr_type != EXPR_CONSTANT)
664 kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
666 return &gfc_bad_expr;
668 if (mpz_cmp_si (e->value.integer, 0) < 0)
670 gfc_error ("Argument of %s function at %L is negative", name,
672 return &gfc_bad_expr;
675 if (ascii && gfc_option.warn_surprising
676 && mpz_cmp_si (e->value.integer, 127) > 0)
677 gfc_warning ("Argument of %s function at %L outside of range [0,127]",
680 if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
685 mpz_init_set_ui (t, 2);
686 mpz_pow_ui (t, t, 32);
687 mpz_sub_ui (t, t, 1);
688 if (mpz_cmp (e->value.integer, t) > 0)
695 gfc_error ("Argument of %s function at %L is too large for the "
696 "collating sequence of kind %d", name, &e->where, kind);
697 return &gfc_bad_expr;
700 result = gfc_get_character_expr (kind, &e->where, NULL, 1);
701 result->value.character.string[0] = mpz_get_ui (e->value.integer);
708 /* We use the processor's collating sequence, because all
709 systems that gfortran currently works on are ASCII. */
712 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
714 return simplify_achar_char (e, k, "ACHAR", true);
719 gfc_simplify_acos (gfc_expr *x)
723 if (x->expr_type != EXPR_CONSTANT)
729 if (mpfr_cmp_si (x->value.real, 1) > 0
730 || mpfr_cmp_si (x->value.real, -1) < 0)
732 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
734 return &gfc_bad_expr;
736 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
737 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
741 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
742 mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
746 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
749 return range_check (result, "ACOS");
753 gfc_simplify_acosh (gfc_expr *x)
757 if (x->expr_type != EXPR_CONSTANT)
763 if (mpfr_cmp_si (x->value.real, 1) < 0)
765 gfc_error ("Argument of ACOSH at %L must not be less than 1",
767 return &gfc_bad_expr;
770 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
771 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
775 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
776 mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
780 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
783 return range_check (result, "ACOSH");
787 gfc_simplify_adjustl (gfc_expr *e)
793 if (e->expr_type != EXPR_CONSTANT)
796 len = e->value.character.length;
798 for (count = 0, i = 0; i < len; ++i)
800 ch = e->value.character.string[i];
806 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
807 for (i = 0; i < len - count; ++i)
808 result->value.character.string[i] = e->value.character.string[count + i];
815 gfc_simplify_adjustr (gfc_expr *e)
821 if (e->expr_type != EXPR_CONSTANT)
824 len = e->value.character.length;
826 for (count = 0, i = len - 1; i >= 0; --i)
828 ch = e->value.character.string[i];
834 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
835 for (i = 0; i < count; ++i)
836 result->value.character.string[i] = ' ';
838 for (i = count; i < len; ++i)
839 result->value.character.string[i] = e->value.character.string[i - count];
846 gfc_simplify_aimag (gfc_expr *e)
850 if (e->expr_type != EXPR_CONSTANT)
853 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
854 mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
856 return range_check (result, "AIMAG");
861 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
863 gfc_expr *rtrunc, *result;
866 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
868 return &gfc_bad_expr;
870 if (e->expr_type != EXPR_CONSTANT)
873 rtrunc = gfc_copy_expr (e);
874 mpfr_trunc (rtrunc->value.real, e->value.real);
876 result = gfc_real2real (rtrunc, kind);
878 gfc_free_expr (rtrunc);
880 return range_check (result, "AINT");
885 gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
889 if (!is_constant_array_expr (mask)
890 || !gfc_is_constant_expr (dim))
893 result = transformational_result (mask, dim, mask->ts.type,
894 mask->ts.kind, &mask->where);
895 init_result_expr (result, true, NULL);
897 return !dim || mask->rank == 1 ?
898 simplify_transformation_to_scalar (result, mask, NULL, gfc_and) :
899 simplify_transformation_to_array (result, mask, dim, NULL, gfc_and);
904 gfc_simplify_dint (gfc_expr *e)
906 gfc_expr *rtrunc, *result;
908 if (e->expr_type != EXPR_CONSTANT)
911 rtrunc = gfc_copy_expr (e);
912 mpfr_trunc (rtrunc->value.real, e->value.real);
914 result = gfc_real2real (rtrunc, gfc_default_double_kind);
916 gfc_free_expr (rtrunc);
918 return range_check (result, "DINT");
923 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
928 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
930 return &gfc_bad_expr;
932 if (e->expr_type != EXPR_CONSTANT)
935 result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
936 mpfr_round (result->value.real, e->value.real);
938 return range_check (result, "ANINT");
943 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
948 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
951 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
956 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
957 mpz_and (result->value.integer, x->value.integer, y->value.integer);
958 return range_check (result, "AND");
961 return gfc_get_logical_expr (kind, &x->where,
962 x->value.logical && y->value.logical);
971 gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
975 if (!is_constant_array_expr (mask)
976 || !gfc_is_constant_expr (dim))
979 result = transformational_result (mask, dim, mask->ts.type,
980 mask->ts.kind, &mask->where);
981 init_result_expr (result, false, NULL);
983 return !dim || mask->rank == 1 ?
984 simplify_transformation_to_scalar (result, mask, NULL, gfc_or) :
985 simplify_transformation_to_array (result, mask, dim, NULL, gfc_or);
990 gfc_simplify_dnint (gfc_expr *e)
994 if (e->expr_type != EXPR_CONSTANT)
997 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
998 mpfr_round (result->value.real, e->value.real);
1000 return range_check (result, "DNINT");
1005 gfc_simplify_asin (gfc_expr *x)
1009 if (x->expr_type != EXPR_CONSTANT)
1015 if (mpfr_cmp_si (x->value.real, 1) > 0
1016 || mpfr_cmp_si (x->value.real, -1) < 0)
1018 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1020 return &gfc_bad_expr;
1022 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1023 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1027 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1028 mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1032 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1035 return range_check (result, "ASIN");
1040 gfc_simplify_asinh (gfc_expr *x)
1044 if (x->expr_type != EXPR_CONSTANT)
1047 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1052 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
1056 mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1060 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1063 return range_check (result, "ASINH");
1068 gfc_simplify_atan (gfc_expr *x)
1072 if (x->expr_type != EXPR_CONSTANT)
1075 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1080 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1084 mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1088 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1091 return range_check (result, "ATAN");
1096 gfc_simplify_atanh (gfc_expr *x)
1100 if (x->expr_type != EXPR_CONSTANT)
1106 if (mpfr_cmp_si (x->value.real, 1) >= 0
1107 || mpfr_cmp_si (x->value.real, -1) <= 0)
1109 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1111 return &gfc_bad_expr;
1113 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1114 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
1118 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1119 mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1123 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1126 return range_check (result, "ATANH");
1131 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
1135 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1138 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
1140 gfc_error ("If first argument of ATAN2 %L is zero, then the "
1141 "second argument must not be zero", &x->where);
1142 return &gfc_bad_expr;
1145 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1146 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
1148 return range_check (result, "ATAN2");
1153 gfc_simplify_bessel_j0 (gfc_expr *x)
1157 if (x->expr_type != EXPR_CONSTANT)
1160 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1161 mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
1163 return range_check (result, "BESSEL_J0");
1168 gfc_simplify_bessel_j1 (gfc_expr *x)
1172 if (x->expr_type != EXPR_CONSTANT)
1175 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1176 mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
1178 return range_check (result, "BESSEL_J1");
1183 gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
1188 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1191 n = mpz_get_si (order->value.integer);
1192 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1193 mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
1195 return range_check (result, "BESSEL_JN");
1200 gfc_simplify_bessel_y0 (gfc_expr *x)
1204 if (x->expr_type != EXPR_CONSTANT)
1207 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1208 mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
1210 return range_check (result, "BESSEL_Y0");
1215 gfc_simplify_bessel_y1 (gfc_expr *x)
1219 if (x->expr_type != EXPR_CONSTANT)
1222 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1223 mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
1225 return range_check (result, "BESSEL_Y1");
1230 gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
1235 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1238 n = mpz_get_si (order->value.integer);
1239 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1240 mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
1242 return range_check (result, "BESSEL_YN");
1247 gfc_simplify_bit_size (gfc_expr *e)
1249 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1250 return gfc_get_int_expr (e->ts.kind, &e->where,
1251 gfc_integer_kinds[i].bit_size);
1256 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
1260 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
1263 if (gfc_extract_int (bit, &b) != NULL || b < 0)
1264 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
1266 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
1267 mpz_tstbit (e->value.integer, b));
1272 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
1274 gfc_expr *ceil, *result;
1277 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
1279 return &gfc_bad_expr;
1281 if (e->expr_type != EXPR_CONSTANT)
1284 ceil = gfc_copy_expr (e);
1285 mpfr_ceil (ceil->value.real, e->value.real);
1287 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
1288 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
1290 gfc_free_expr (ceil);
1292 return range_check (result, "CEILING");
1297 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1299 return simplify_achar_char (e, k, "CHAR", false);
1303 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1306 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1310 if (convert_boz (x, kind) == &gfc_bad_expr)
1311 return &gfc_bad_expr;
1313 if (convert_boz (y, kind) == &gfc_bad_expr)
1314 return &gfc_bad_expr;
1316 if (x->expr_type != EXPR_CONSTANT
1317 || (y != NULL && y->expr_type != EXPR_CONSTANT))
1320 result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
1325 mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
1329 mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
1333 mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1337 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1341 return range_check (result, name);
1346 mpfr_set_z (mpc_imagref (result->value.complex),
1347 y->value.integer, GFC_RND_MODE);
1351 mpfr_set (mpc_imagref (result->value.complex),
1352 y->value.real, GFC_RND_MODE);
1356 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1359 return range_check (result, name);
1364 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1368 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
1370 return &gfc_bad_expr;
1372 return simplify_cmplx ("CMPLX", x, y, kind);
1377 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
1381 if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
1382 kind = gfc_default_complex_kind;
1383 else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
1385 else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
1387 else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
1388 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
1392 return simplify_cmplx ("COMPLEX", x, y, kind);
1397 gfc_simplify_conjg (gfc_expr *e)
1401 if (e->expr_type != EXPR_CONSTANT)
1404 result = gfc_copy_expr (e);
1405 mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
1407 return range_check (result, "CONJG");
1412 gfc_simplify_cos (gfc_expr *x)
1416 if (x->expr_type != EXPR_CONSTANT)
1419 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1424 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1428 gfc_set_model_kind (x->ts.kind);
1429 mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1433 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1436 return range_check (result, "COS");
1441 gfc_simplify_cosh (gfc_expr *x)
1445 if (x->expr_type != EXPR_CONSTANT)
1448 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1453 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1457 mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1464 return range_check (result, "COSH");
1469 gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1473 if (!is_constant_array_expr (mask)
1474 || !gfc_is_constant_expr (dim)
1475 || !gfc_is_constant_expr (kind))
1478 result = transformational_result (mask, dim,
1480 get_kind (BT_INTEGER, kind, "COUNT",
1481 gfc_default_integer_kind),
1484 init_result_expr (result, 0, NULL);
1486 /* Passing MASK twice, once as data array, once as mask.
1487 Whenever gfc_count is called, '1' is added to the result. */
1488 return !dim || mask->rank == 1 ?
1489 simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
1490 simplify_transformation_to_array (result, mask, dim, mask, gfc_count);
1495 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
1497 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
1502 gfc_simplify_dble (gfc_expr *e)
1504 gfc_expr *result = NULL;
1506 if (e->expr_type != EXPR_CONSTANT)
1509 if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
1510 return &gfc_bad_expr;
1512 result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
1513 if (result == &gfc_bad_expr)
1514 return &gfc_bad_expr;
1516 return range_check (result, "DBLE");
1521 gfc_simplify_digits (gfc_expr *x)
1525 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1530 digits = gfc_integer_kinds[i].digits;
1535 digits = gfc_real_kinds[i].digits;
1542 return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
1547 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1552 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1555 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1556 result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
1561 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1562 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1564 mpz_set_ui (result->value.integer, 0);
1569 if (mpfr_cmp (x->value.real, y->value.real) > 0)
1570 mpfr_sub (result->value.real, x->value.real, y->value.real,
1573 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1578 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1581 return range_check (result, "DIM");
1586 gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1588 if (!is_constant_array_expr (vector_a)
1589 || !is_constant_array_expr (vector_b))
1592 gcc_assert (vector_a->rank == 1);
1593 gcc_assert (vector_b->rank == 1);
1594 gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
1596 return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0);
1601 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1603 gfc_expr *a1, *a2, *result;
1605 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1608 a1 = gfc_real2real (x, gfc_default_double_kind);
1609 a2 = gfc_real2real (y, gfc_default_double_kind);
1611 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
1612 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1617 return range_check (result, "DPROD");
1622 gfc_simplify_erf (gfc_expr *x)
1626 if (x->expr_type != EXPR_CONSTANT)
1629 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1630 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1632 return range_check (result, "ERF");
1637 gfc_simplify_erfc (gfc_expr *x)
1641 if (x->expr_type != EXPR_CONSTANT)
1644 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1645 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1647 return range_check (result, "ERFC");
1651 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
1653 #define MAX_ITER 200
1654 #define ARG_LIMIT 12
1656 /* Calculate ERFC_SCALED directly by its definition:
1658 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
1660 using a large precision for intermediate results. This is used for all
1661 but large values of the argument. */
1663 fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
1668 prec = mpfr_get_default_prec ();
1669 mpfr_set_default_prec (10 * prec);
1674 mpfr_set (a, arg, GFC_RND_MODE);
1675 mpfr_sqr (b, a, GFC_RND_MODE);
1676 mpfr_exp (b, b, GFC_RND_MODE);
1677 mpfr_erfc (a, a, GFC_RND_MODE);
1678 mpfr_mul (a, a, b, GFC_RND_MODE);
1680 mpfr_set (res, a, GFC_RND_MODE);
1681 mpfr_set_default_prec (prec);
1687 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
1689 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
1690 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
1693 This is used for large values of the argument. Intermediate calculations
1694 are performed with twice the precision. We don't do a fixed number of
1695 iterations of the sum, but stop when it has converged to the required
1698 asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
1700 mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
1705 prec = mpfr_get_default_prec ();
1706 mpfr_set_default_prec (2 * prec);
1716 mpfr_init (sumtrunc);
1717 mpfr_set_prec (oldsum, prec);
1718 mpfr_set_prec (sumtrunc, prec);
1720 mpfr_set (x, arg, GFC_RND_MODE);
1721 mpfr_set_ui (sum, 1, GFC_RND_MODE);
1722 mpz_set_ui (num, 1);
1724 mpfr_set (u, x, GFC_RND_MODE);
1725 mpfr_sqr (u, u, GFC_RND_MODE);
1726 mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
1727 mpfr_pow_si (u, u, -1, GFC_RND_MODE);
1729 for (i = 1; i < MAX_ITER; i++)
1731 mpfr_set (oldsum, sum, GFC_RND_MODE);
1733 mpz_mul_ui (num, num, 2 * i - 1);
1736 mpfr_set (w, u, GFC_RND_MODE);
1737 mpfr_pow_ui (w, w, i, GFC_RND_MODE);
1739 mpfr_set_z (v, num, GFC_RND_MODE);
1740 mpfr_mul (v, v, w, GFC_RND_MODE);
1742 mpfr_add (sum, sum, v, GFC_RND_MODE);
1744 mpfr_set (sumtrunc, sum, GFC_RND_MODE);
1745 if (mpfr_cmp (sumtrunc, oldsum) == 0)
1749 /* We should have converged by now; otherwise, ARG_LIMIT is probably
1751 gcc_assert (i < MAX_ITER);
1753 /* Divide by x * sqrt(Pi). */
1754 mpfr_const_pi (u, GFC_RND_MODE);
1755 mpfr_sqrt (u, u, GFC_RND_MODE);
1756 mpfr_mul (u, u, x, GFC_RND_MODE);
1757 mpfr_div (sum, sum, u, GFC_RND_MODE);
1759 mpfr_set (res, sum, GFC_RND_MODE);
1760 mpfr_set_default_prec (prec);
1762 mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
1768 gfc_simplify_erfc_scaled (gfc_expr *x)
1772 if (x->expr_type != EXPR_CONSTANT)
1775 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1776 if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
1777 asympt_erfc_scaled (result->value.real, x->value.real);
1779 fullprec_erfc_scaled (result->value.real, x->value.real);
1781 return range_check (result, "ERFC_SCALED");
1789 gfc_simplify_epsilon (gfc_expr *e)
1794 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1796 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
1797 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1799 return range_check (result, "EPSILON");
1804 gfc_simplify_exp (gfc_expr *x)
1808 if (x->expr_type != EXPR_CONSTANT)
1811 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1816 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1820 gfc_set_model_kind (x->ts.kind);
1821 mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1825 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1828 return range_check (result, "EXP");
1833 gfc_simplify_exponent (gfc_expr *x)
1838 if (x->expr_type != EXPR_CONSTANT)
1841 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1844 gfc_set_model (x->value.real);
1846 if (mpfr_sgn (x->value.real) == 0)
1848 mpz_set_ui (result->value.integer, 0);
1852 i = (int) mpfr_get_exp (x->value.real);
1853 mpz_set_si (result->value.integer, i);
1855 return range_check (result, "EXPONENT");
1860 gfc_simplify_float (gfc_expr *a)
1864 if (a->expr_type != EXPR_CONSTANT)
1869 if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
1870 return &gfc_bad_expr;
1872 result = gfc_copy_expr (a);
1875 result = gfc_int2real (a, gfc_default_real_kind);
1877 return range_check (result, "FLOAT");
1882 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1888 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1890 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1892 if (e->expr_type != EXPR_CONSTANT)
1895 gfc_set_model_kind (kind);
1898 mpfr_floor (floor, e->value.real);
1900 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
1901 gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
1905 return range_check (result, "FLOOR");
1910 gfc_simplify_fraction (gfc_expr *x)
1913 mpfr_t absv, exp, pow2;
1915 if (x->expr_type != EXPR_CONSTANT)
1918 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
1920 if (mpfr_sgn (x->value.real) == 0)
1922 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1926 gfc_set_model_kind (x->ts.kind);
1931 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1932 mpfr_log2 (exp, absv, GFC_RND_MODE);
1934 mpfr_trunc (exp, exp);
1935 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1937 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1939 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1941 mpfr_clears (exp, absv, pow2, NULL);
1943 return range_check (result, "FRACTION");
1948 gfc_simplify_gamma (gfc_expr *x)
1952 if (x->expr_type != EXPR_CONSTANT)
1955 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1956 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1958 return range_check (result, "GAMMA");
1963 gfc_simplify_huge (gfc_expr *e)
1968 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1969 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
1974 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1978 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1990 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
1994 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1997 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1998 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
1999 return range_check (result, "HYPOT");
2003 /* We use the processor's collating sequence, because all
2004 systems that gfortran currently works on are ASCII. */
2007 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
2013 if (e->expr_type != EXPR_CONSTANT)
2016 if (e->value.character.length != 1)
2018 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
2019 return &gfc_bad_expr;
2022 index = e->value.character.string[0];
2024 if (gfc_option.warn_surprising && index > 127)
2025 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
2028 k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
2030 return &gfc_bad_expr;
2032 result = gfc_get_int_expr (k, &e->where, index);
2034 return range_check (result, "IACHAR");
2039 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
2043 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2046 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2047 mpz_and (result->value.integer, x->value.integer, y->value.integer);
2049 return range_check (result, "IAND");
2054 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
2059 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2062 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2064 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
2065 return &gfc_bad_expr;
2068 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2070 if (pos >= gfc_integer_kinds[k].bit_size)
2072 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
2074 return &gfc_bad_expr;
2077 result = gfc_copy_expr (x);
2079 convert_mpz_to_unsigned (result->value.integer,
2080 gfc_integer_kinds[k].bit_size);
2082 mpz_clrbit (result->value.integer, pos);
2084 convert_mpz_to_signed (result->value.integer,
2085 gfc_integer_kinds[k].bit_size);
2092 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2099 if (x->expr_type != EXPR_CONSTANT
2100 || y->expr_type != EXPR_CONSTANT
2101 || z->expr_type != EXPR_CONSTANT)
2104 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2106 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
2107 return &gfc_bad_expr;
2110 if (gfc_extract_int (z, &len) != NULL || len < 0)
2112 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
2113 return &gfc_bad_expr;
2116 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
2118 bitsize = gfc_integer_kinds[k].bit_size;
2120 if (pos + len > bitsize)
2122 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2123 "bit size at %L", &y->where);
2124 return &gfc_bad_expr;
2127 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2128 convert_mpz_to_unsigned (result->value.integer,
2129 gfc_integer_kinds[k].bit_size);
2131 bits = XCNEWVEC (int, bitsize);
2133 for (i = 0; i < bitsize; i++)
2136 for (i = 0; i < len; i++)
2137 bits[i] = mpz_tstbit (x->value.integer, i + pos);
2139 for (i = 0; i < bitsize; i++)
2142 mpz_clrbit (result->value.integer, i);
2143 else if (bits[i] == 1)
2144 mpz_setbit (result->value.integer, i);
2146 gfc_internal_error ("IBITS: Bad bit");
2151 convert_mpz_to_signed (result->value.integer,
2152 gfc_integer_kinds[k].bit_size);
2159 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
2164 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2167 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2169 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
2170 return &gfc_bad_expr;
2173 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2175 if (pos >= gfc_integer_kinds[k].bit_size)
2177 gfc_error ("Second argument of IBSET exceeds bit size at %L",
2179 return &gfc_bad_expr;
2182 result = gfc_copy_expr (x);
2184 convert_mpz_to_unsigned (result->value.integer,
2185 gfc_integer_kinds[k].bit_size);
2187 mpz_setbit (result->value.integer, pos);
2189 convert_mpz_to_signed (result->value.integer,
2190 gfc_integer_kinds[k].bit_size);
2197 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
2203 if (e->expr_type != EXPR_CONSTANT)
2206 if (e->value.character.length != 1)
2208 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
2209 return &gfc_bad_expr;
2212 index = e->value.character.string[0];
2214 k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
2216 return &gfc_bad_expr;
2218 result = gfc_get_int_expr (k, &e->where, index);
2220 return range_check (result, "ICHAR");
2225 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
2229 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2232 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2233 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
2235 return range_check (result, "IEOR");
2240 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
2243 int back, len, lensub;
2244 int i, j, k, count, index = 0, start;
2246 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
2247 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
2250 if (b != NULL && b->value.logical != 0)
2255 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
2257 return &gfc_bad_expr;
2259 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
2261 len = x->value.character.length;
2262 lensub = y->value.character.length;
2266 mpz_set_si (result->value.integer, 0);
2274 mpz_set_si (result->value.integer, 1);
2277 else if (lensub == 1)
2279 for (i = 0; i < len; i++)
2281 for (j = 0; j < lensub; j++)
2283 if (y->value.character.string[j]
2284 == x->value.character.string[i])
2294 for (i = 0; i < len; i++)
2296 for (j = 0; j < lensub; j++)
2298 if (y->value.character.string[j]
2299 == x->value.character.string[i])
2304 for (k = 0; k < lensub; k++)
2306 if (y->value.character.string[k]
2307 == x->value.character.string[k + start])
2311 if (count == lensub)
2326 mpz_set_si (result->value.integer, len + 1);
2329 else if (lensub == 1)
2331 for (i = 0; i < len; i++)
2333 for (j = 0; j < lensub; j++)
2335 if (y->value.character.string[j]
2336 == x->value.character.string[len - i])
2338 index = len - i + 1;
2346 for (i = 0; i < len; i++)
2348 for (j = 0; j < lensub; j++)
2350 if (y->value.character.string[j]
2351 == x->value.character.string[len - i])
2354 if (start <= len - lensub)
2357 for (k = 0; k < lensub; k++)
2358 if (y->value.character.string[k]
2359 == x->value.character.string[k + start])
2362 if (count == lensub)
2379 mpz_set_si (result->value.integer, index);
2380 return range_check (result, "INDEX");
2385 simplify_intconv (gfc_expr *e, int kind, const char *name)
2387 gfc_expr *result = NULL;
2389 if (e->expr_type != EXPR_CONSTANT)
2392 result = gfc_convert_constant (e, BT_INTEGER, kind);
2393 if (result == &gfc_bad_expr)
2394 return &gfc_bad_expr;
2396 return range_check (result, name);
2401 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
2405 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
2407 return &gfc_bad_expr;
2409 return simplify_intconv (e, kind, "INT");
2413 gfc_simplify_int2 (gfc_expr *e)
2415 return simplify_intconv (e, 2, "INT2");
2420 gfc_simplify_int8 (gfc_expr *e)
2422 return simplify_intconv (e, 8, "INT8");
2427 gfc_simplify_long (gfc_expr *e)
2429 return simplify_intconv (e, 4, "LONG");
2434 gfc_simplify_ifix (gfc_expr *e)
2436 gfc_expr *rtrunc, *result;
2438 if (e->expr_type != EXPR_CONSTANT)
2441 rtrunc = gfc_copy_expr (e);
2442 mpfr_trunc (rtrunc->value.real, e->value.real);
2444 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2446 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2448 gfc_free_expr (rtrunc);
2450 return range_check (result, "IFIX");
2455 gfc_simplify_idint (gfc_expr *e)
2457 gfc_expr *rtrunc, *result;
2459 if (e->expr_type != EXPR_CONSTANT)
2462 rtrunc = gfc_copy_expr (e);
2463 mpfr_trunc (rtrunc->value.real, e->value.real);
2465 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2467 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2469 gfc_free_expr (rtrunc);
2471 return range_check (result, "IDINT");
2476 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
2480 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2483 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2484 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2486 return range_check (result, "IOR");
2491 gfc_simplify_is_iostat_end (gfc_expr *x)
2493 if (x->expr_type != EXPR_CONSTANT)
2496 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2497 mpz_cmp_si (x->value.integer,
2498 LIBERROR_END) == 0);
2503 gfc_simplify_is_iostat_eor (gfc_expr *x)
2505 if (x->expr_type != EXPR_CONSTANT)
2508 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2509 mpz_cmp_si (x->value.integer,
2510 LIBERROR_EOR) == 0);
2515 gfc_simplify_isnan (gfc_expr *x)
2517 if (x->expr_type != EXPR_CONSTANT)
2520 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2521 mpfr_nan_p (x->value.real));
2526 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
2529 int shift, ashift, isize, k, *bits, i;
2531 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2534 if (gfc_extract_int (s, &shift) != NULL)
2536 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
2537 return &gfc_bad_expr;
2540 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2542 isize = gfc_integer_kinds[k].bit_size;
2551 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
2552 "at %L", &s->where);
2553 return &gfc_bad_expr;
2556 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
2560 mpz_set (result->value.integer, e->value.integer);
2561 return range_check (result, "ISHFT");
2564 bits = XCNEWVEC (int, isize);
2566 for (i = 0; i < isize; i++)
2567 bits[i] = mpz_tstbit (e->value.integer, i);
2571 for (i = 0; i < shift; i++)
2572 mpz_clrbit (result->value.integer, i);
2574 for (i = 0; i < isize - shift; i++)
2577 mpz_clrbit (result->value.integer, i + shift);
2579 mpz_setbit (result->value.integer, i + shift);
2584 for (i = isize - 1; i >= isize - ashift; i--)
2585 mpz_clrbit (result->value.integer, i);
2587 for (i = isize - 1; i >= ashift; i--)
2590 mpz_clrbit (result->value.integer, i - ashift);
2592 mpz_setbit (result->value.integer, i - ashift);
2596 convert_mpz_to_signed (result->value.integer, isize);
2604 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
2607 int shift, ashift, isize, ssize, delta, k;
2610 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2613 if (gfc_extract_int (s, &shift) != NULL)
2615 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
2616 return &gfc_bad_expr;
2619 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2620 isize = gfc_integer_kinds[k].bit_size;
2624 if (sz->expr_type != EXPR_CONSTANT)
2627 if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
2629 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
2630 return &gfc_bad_expr;
2635 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
2636 "BIT_SIZE of first argument at %L", &s->where);
2637 return &gfc_bad_expr;
2651 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2652 "third argument at %L", &s->where);
2654 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2655 "BIT_SIZE of first argument at %L", &s->where);
2656 return &gfc_bad_expr;
2659 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
2661 mpz_set (result->value.integer, e->value.integer);
2666 convert_mpz_to_unsigned (result->value.integer, isize);
2668 bits = XCNEWVEC (int, ssize);
2670 for (i = 0; i < ssize; i++)
2671 bits[i] = mpz_tstbit (e->value.integer, i);
2673 delta = ssize - ashift;
2677 for (i = 0; i < delta; i++)
2680 mpz_clrbit (result->value.integer, i + shift);
2682 mpz_setbit (result->value.integer, i + shift);
2685 for (i = delta; i < ssize; i++)
2688 mpz_clrbit (result->value.integer, i - delta);
2690 mpz_setbit (result->value.integer, i - delta);
2695 for (i = 0; i < ashift; i++)
2698 mpz_clrbit (result->value.integer, i + delta);
2700 mpz_setbit (result->value.integer, i + delta);
2703 for (i = ashift; i < ssize; i++)
2706 mpz_clrbit (result->value.integer, i + shift);
2708 mpz_setbit (result->value.integer, i + shift);
2712 convert_mpz_to_signed (result->value.integer, isize);
2720 gfc_simplify_kind (gfc_expr *e)
2722 return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
2727 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2728 gfc_array_spec *as, gfc_ref *ref, bool coarray)
2730 gfc_expr *l, *u, *result;
2733 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2734 gfc_default_integer_kind);
2736 return &gfc_bad_expr;
2738 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
2740 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
2741 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
2742 if (!coarray && array->expr_type != EXPR_VARIABLE)
2746 gfc_expr* dim = result;
2747 mpz_set_si (dim->value.integer, d);
2749 result = gfc_simplify_size (array, dim, kind);
2750 gfc_free_expr (dim);
2755 mpz_set_si (result->value.integer, 1);
2760 /* Otherwise, we have a variable expression. */
2761 gcc_assert (array->expr_type == EXPR_VARIABLE);
2764 /* The last dimension of an assumed-size array is special. */
2765 if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2766 || (coarray && d == as->rank + as->corank))
2768 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2770 gfc_free_expr (result);
2771 return gfc_copy_expr (as->lower[d-1]);
2777 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
2779 /* Then, we need to know the extent of the given dimension. */
2780 if (coarray || ref->u.ar.type == AR_FULL)
2785 if (l->expr_type != EXPR_CONSTANT || u == NULL
2786 || u->expr_type != EXPR_CONSTANT)
2789 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2793 mpz_set_si (result->value.integer, 0);
2795 mpz_set_si (result->value.integer, 1);
2799 /* Nonzero extent. */
2801 mpz_set (result->value.integer, u->value.integer);
2803 mpz_set (result->value.integer, l->value.integer);
2810 if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer)
2815 mpz_set_si (result->value.integer, (long int) 1);
2819 return range_check (result, upper ? "UBOUND" : "LBOUND");
2822 gfc_free_expr (result);
2828 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2834 if (array->expr_type != EXPR_VARIABLE)
2841 /* Follow any component references. */
2842 as = array->symtree->n.sym->as;
2843 for (ref = array->ref; ref; ref = ref->next)
2848 switch (ref->u.ar.type)
2855 /* We're done because 'as' has already been set in the
2856 previous iteration. */
2873 as = ref->u.c.component->as;
2885 if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
2890 /* Multi-dimensional bounds. */
2891 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2895 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2896 if (upper && as && as->type == AS_ASSUMED_SIZE)
2898 /* An error message will be emitted in
2899 check_assumed_size_reference (resolve.c). */
2900 return &gfc_bad_expr;
2903 /* Simplify the bounds for each dimension. */
2904 for (d = 0; d < array->rank; d++)
2906 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
2908 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2912 for (j = 0; j < d; j++)
2913 gfc_free_expr (bounds[j]);
2918 /* Allocate the result expression. */
2919 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2920 gfc_default_integer_kind);
2922 return &gfc_bad_expr;
2924 e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
2926 /* The result is a rank 1 array; its size is the rank of the first
2927 argument to {L,U}BOUND. */
2929 e->shape = gfc_get_shape (1);
2930 mpz_init_set_ui (e->shape[0], array->rank);
2932 /* Create the constructor for this array. */
2933 for (d = 0; d < array->rank; d++)
2934 gfc_constructor_append_expr (&e->value.constructor,
2935 bounds[d], &e->where);
2941 /* A DIM argument is specified. */
2942 if (dim->expr_type != EXPR_CONSTANT)
2945 d = mpz_get_si (dim->value.integer);
2947 if (d < 1 || d > array->rank
2948 || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
2950 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2951 return &gfc_bad_expr;
2954 return simplify_bound_dim (array, kind, d, upper, as, ref, false);
2960 simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2966 if (array->expr_type != EXPR_VARIABLE)
2969 /* Follow any component references. */
2970 as = array->symtree->n.sym->as;
2971 for (ref = array->ref; ref; ref = ref->next)
2976 switch (ref->u.ar.type)
2979 if (ref->next == NULL)
2981 gcc_assert (ref->u.ar.as->corank > 0
2982 && ref->u.ar.as->rank == 0);
2990 /* We're done because 'as' has already been set in the
2991 previous iteration. */
3008 as = ref->u.c.component->as;
3020 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
3025 /* Multi-dimensional cobounds. */
3026 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3030 /* Simplify the cobounds for each dimension. */
3031 for (d = 0; d < as->corank; d++)
3033 bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
3034 upper, as, ref, true);
3035 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3039 for (j = 0; j < d; j++)
3040 gfc_free_expr (bounds[j]);
3045 /* Allocate the result expression. */
3046 e = gfc_get_expr ();
3047 e->where = array->where;
3048 e->expr_type = EXPR_ARRAY;
3049 e->ts.type = BT_INTEGER;
3050 k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
3051 gfc_default_integer_kind);
3055 return &gfc_bad_expr;
3059 /* The result is a rank 1 array; its size is the rank of the first
3060 argument to {L,U}COBOUND. */
3062 e->shape = gfc_get_shape (1);
3063 mpz_init_set_ui (e->shape[0], as->corank);
3065 /* Create the constructor for this array. */
3066 for (d = 0; d < as->corank; d++)
3067 gfc_constructor_append_expr (&e->value.constructor,
3068 bounds[d], &e->where);
3073 /* A DIM argument is specified. */
3074 if (dim->expr_type != EXPR_CONSTANT)
3077 d = mpz_get_si (dim->value.integer);
3079 if (d < 1 || d > as->corank)
3081 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3082 return &gfc_bad_expr;
3085 return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
3091 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3093 return simplify_bound (array, dim, kind, 0);
3098 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3101 /* return simplify_cobound (array, dim, kind, 0);*/
3103 e = simplify_cobound (array, dim, kind, 0);
3107 gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
3108 "cobounds at %L", &array->where);
3109 return &gfc_bad_expr;
3113 gfc_simplify_leadz (gfc_expr *e)
3115 unsigned long lz, bs;
3118 if (e->expr_type != EXPR_CONSTANT)
3121 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3122 bs = gfc_integer_kinds[i].bit_size;
3123 if (mpz_cmp_si (e->value.integer, 0) == 0)
3125 else if (mpz_cmp_si (e->value.integer, 0) < 0)
3128 lz = bs - mpz_sizeinbase (e->value.integer, 2);
3130 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
3135 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
3138 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
3141 return &gfc_bad_expr;
3143 if (e->expr_type == EXPR_CONSTANT)
3145 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3146 mpz_set_si (result->value.integer, e->value.character.length);
3147 return range_check (result, "LEN");
3149 else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3150 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3151 && e->ts.u.cl->length->ts.type == BT_INTEGER)
3153 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3154 mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
3155 return range_check (result, "LEN");
3163 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
3167 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3170 return &gfc_bad_expr;
3172 if (e->expr_type != EXPR_CONSTANT)
3175 len = e->value.character.length;
3176 for (count = 0, i = 1; i <= len; i++)
3177 if (e->value.character.string[len - i] == ' ')
3182 result = gfc_get_int_expr (k, &e->where, len - count);
3183 return range_check (result, "LEN_TRIM");
3187 gfc_simplify_lgamma (gfc_expr *x)
3192 if (x->expr_type != EXPR_CONSTANT)
3195 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3196 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
3198 return range_check (result, "LGAMMA");
3203 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
3205 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3208 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3209 gfc_compare_string (a, b) >= 0);
3214 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
3216 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3219 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3220 gfc_compare_string (a, b) > 0);
3225 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
3227 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3230 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3231 gfc_compare_string (a, b) <= 0);
3236 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
3238 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3241 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3242 gfc_compare_string (a, b) < 0);
3247 gfc_simplify_log (gfc_expr *x)
3251 if (x->expr_type != EXPR_CONSTANT)
3254 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3259 if (mpfr_sgn (x->value.real) <= 0)
3261 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3262 "to zero", &x->where);
3263 gfc_free_expr (result);
3264 return &gfc_bad_expr;
3267 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
3271 if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3272 && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
3274 gfc_error ("Complex argument of LOG at %L cannot be zero",
3276 gfc_free_expr (result);
3277 return &gfc_bad_expr;
3280 gfc_set_model_kind (x->ts.kind);
3281 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3285 gfc_internal_error ("gfc_simplify_log: bad type");
3288 return range_check (result, "LOG");
3293 gfc_simplify_log10 (gfc_expr *x)
3297 if (x->expr_type != EXPR_CONSTANT)
3300 if (mpfr_sgn (x->value.real) <= 0)
3302 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3303 "to zero", &x->where);
3304 return &gfc_bad_expr;
3307 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3308 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
3310 return range_check (result, "LOG10");
3315 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
3319 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
3321 return &gfc_bad_expr;
3323 if (e->expr_type != EXPR_CONSTANT)
3326 return gfc_get_logical_expr (kind, &e->where, e->value.logical);
3331 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3334 int row, result_rows, col, result_columns;
3335 int stride_a, offset_a, stride_b, offset_b;
3337 if (!is_constant_array_expr (matrix_a)
3338 || !is_constant_array_expr (matrix_b))
3341 gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
3342 result = gfc_get_array_expr (matrix_a->ts.type,
3346 if (matrix_a->rank == 1 && matrix_b->rank == 2)
3349 result_columns = mpz_get_si (matrix_b->shape[0]);
3351 stride_b = mpz_get_si (matrix_b->shape[0]);
3354 result->shape = gfc_get_shape (result->rank);
3355 mpz_init_set_si (result->shape[0], result_columns);
3357 else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3359 result_rows = mpz_get_si (matrix_b->shape[0]);
3361 stride_a = mpz_get_si (matrix_a->shape[0]);
3365 result->shape = gfc_get_shape (result->rank);
3366 mpz_init_set_si (result->shape[0], result_rows);
3368 else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3370 result_rows = mpz_get_si (matrix_a->shape[0]);
3371 result_columns = mpz_get_si (matrix_b->shape[1]);
3372 stride_a = mpz_get_si (matrix_a->shape[1]);
3373 stride_b = mpz_get_si (matrix_b->shape[0]);
3376 result->shape = gfc_get_shape (result->rank);
3377 mpz_init_set_si (result->shape[0], result_rows);
3378 mpz_init_set_si (result->shape[1], result_columns);
3383 offset_a = offset_b = 0;
3384 for (col = 0; col < result_columns; ++col)
3388 for (row = 0; row < result_rows; ++row)
3390 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
3391 matrix_b, 1, offset_b);
3392 gfc_constructor_append_expr (&result->value.constructor,
3398 offset_b += stride_b;
3406 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3408 if (tsource->expr_type != EXPR_CONSTANT
3409 || fsource->expr_type != EXPR_CONSTANT
3410 || mask->expr_type != EXPR_CONSTANT)
3413 return gfc_copy_expr (mask->value.logical ? tsource : fsource);
3417 /* Selects bewteen current value and extremum for simplify_min_max
3418 and simplify_minval_maxval. */
3420 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
3422 switch (arg->ts.type)
3425 if (mpz_cmp (arg->value.integer,
3426 extremum->value.integer) * sign > 0)
3427 mpz_set (extremum->value.integer, arg->value.integer);
3431 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
3433 mpfr_max (extremum->value.real, extremum->value.real,
3434 arg->value.real, GFC_RND_MODE);
3436 mpfr_min (extremum->value.real, extremum->value.real,
3437 arg->value.real, GFC_RND_MODE);
3441 #define LENGTH(x) ((x)->value.character.length)
3442 #define STRING(x) ((x)->value.character.string)
3443 if (LENGTH(extremum) < LENGTH(arg))
3445 gfc_char_t *tmp = STRING(extremum);
3447 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
3448 memcpy (STRING(extremum), tmp,
3449 LENGTH(extremum) * sizeof (gfc_char_t));
3450 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
3451 LENGTH(arg) - LENGTH(extremum));
3452 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
3453 LENGTH(extremum) = LENGTH(arg);
3457 if (gfc_compare_string (arg, extremum) * sign > 0)
3459 gfc_free (STRING(extremum));
3460 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
3461 memcpy (STRING(extremum), STRING(arg),
3462 LENGTH(arg) * sizeof (gfc_char_t));
3463 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
3464 LENGTH(extremum) - LENGTH(arg));
3465 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
3472 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
3477 /* This function is special since MAX() can take any number of
3478 arguments. The simplified expression is a rewritten version of the
3479 argument list containing at most one constant element. Other
3480 constant elements are deleted. Because the argument list has
3481 already been checked, this function always succeeds. sign is 1 for
3482 MAX(), -1 for MIN(). */
3485 simplify_min_max (gfc_expr *expr, int sign)
3487 gfc_actual_arglist *arg, *last, *extremum;
3488 gfc_intrinsic_sym * specific;
3492 specific = expr->value.function.isym;
3494 arg = expr->value.function.actual;
3496 for (; arg; last = arg, arg = arg->next)
3498 if (arg->expr->expr_type != EXPR_CONSTANT)
3501 if (extremum == NULL)
3507 min_max_choose (arg->expr, extremum->expr, sign);
3509 /* Delete the extra constant argument. */
3511 expr->value.function.actual = arg->next;
3513 last->next = arg->next;
3516 gfc_free_actual_arglist (arg);
3520 /* If there is one value left, replace the function call with the
3522 if (expr->value.function.actual->next != NULL)
3525 /* Convert to the correct type and kind. */
3526 if (expr->ts.type != BT_UNKNOWN)
3527 return gfc_convert_constant (expr->value.function.actual->expr,
3528 expr->ts.type, expr->ts.kind);
3530 if (specific->ts.type != BT_UNKNOWN)
3531 return gfc_convert_constant (expr->value.function.actual->expr,
3532 specific->ts.type, specific->ts.kind);
3534 return gfc_copy_expr (expr->value.function.actual->expr);
3539 gfc_simplify_min (gfc_expr *e)
3541 return simplify_min_max (e, -1);
3546 gfc_simplify_max (gfc_expr *e)
3548 return simplify_min_max (e, 1);
3552 /* This is a simplified version of simplify_min_max to provide
3553 simplification of minval and maxval for a vector. */
3556 simplify_minval_maxval (gfc_expr *expr, int sign)
3558 gfc_constructor *c, *extremum;
3559 gfc_intrinsic_sym * specific;
3562 specific = expr->value.function.isym;
3564 for (c = gfc_constructor_first (expr->value.constructor);
3565 c; c = gfc_constructor_next (c))
3567 if (c->expr->expr_type != EXPR_CONSTANT)
3570 if (extremum == NULL)
3576 min_max_choose (c->expr, extremum->expr, sign);
3579 if (extremum == NULL)
3582 /* Convert to the correct type and kind. */
3583 if (expr->ts.type != BT_UNKNOWN)
3584 return gfc_convert_constant (extremum->expr,
3585 expr->ts.type, expr->ts.kind);
3587 if (specific->ts.type != BT_UNKNOWN)
3588 return gfc_convert_constant (extremum->expr,
3589 specific->ts.type, specific->ts.kind);
3591 return gfc_copy_expr (extremum->expr);
3596 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3598 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3601 return simplify_minval_maxval (array, -1);
3606 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3608 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3611 return simplify_minval_maxval (array, 1);
3616 gfc_simplify_maxexponent (gfc_expr *x)
3618 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3619 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3620 gfc_real_kinds[i].max_exponent);
3625 gfc_simplify_minexponent (gfc_expr *x)
3627 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3628 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3629 gfc_real_kinds[i].min_exponent);
3634 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
3640 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3643 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3644 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3649 if (mpz_cmp_ui (p->value.integer, 0) == 0)
3651 /* Result is processor-dependent. */
3652 gfc_error ("Second argument MOD at %L is zero", &a->where);
3653 gfc_free_expr (result);
3654 return &gfc_bad_expr;
3656 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
3660 if (mpfr_cmp_ui (p->value.real, 0) == 0)
3662 /* Result is processor-dependent. */
3663 gfc_error ("Second argument of MOD at %L is zero", &p->where);
3664 gfc_free_expr (result);
3665 return &gfc_bad_expr;
3668 gfc_set_model_kind (kind);
3670 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3671 mpfr_trunc (tmp, tmp);
3672 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3673 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3678 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
3681 return range_check (result, "MOD");
3686 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
3692 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3695 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3696 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3701 if (mpz_cmp_ui (p->value.integer, 0) == 0)
3703 /* Result is processor-dependent. This processor just opts
3704 to not handle it at all. */
3705 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
3706 gfc_free_expr (result);
3707 return &gfc_bad_expr;
3709 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
3714 if (mpfr_cmp_ui (p->value.real, 0) == 0)
3716 /* Result is processor-dependent. */
3717 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
3718 gfc_free_expr (result);
3719 return &gfc_bad_expr;
3722 gfc_set_model_kind (kind);
3724 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3725 mpfr_floor (tmp, tmp);
3726 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3727 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3732 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
3735 return range_check (result, "MODULO");
3739 /* Exists for the sole purpose of consistency with other intrinsics. */
3741 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
3742 gfc_expr *fp ATTRIBUTE_UNUSED,
3743 gfc_expr *l ATTRIBUTE_UNUSED,
3744 gfc_expr *to ATTRIBUTE_UNUSED,
3745 gfc_expr *tp ATTRIBUTE_UNUSED)
3752 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
3755 mp_exp_t emin, emax;
3758 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3761 if (mpfr_sgn (s->value.real) == 0)
3763 gfc_error ("Second argument of NEAREST at %L shall not be zero",
3765 return &gfc_bad_expr;
3768 result = gfc_copy_expr (x);
3770 /* Save current values of emin and emax. */
3771 emin = mpfr_get_emin ();
3772 emax = mpfr_get_emax ();
3774 /* Set emin and emax for the current model number. */
3775 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
3776 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
3777 mpfr_get_prec(result->value.real) + 1);
3778 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
3779 mpfr_check_range (result->value.real, 0, GMP_RNDU);
3781 if (mpfr_sgn (s->value.real) > 0)
3783 mpfr_nextabove (result->value.real);
3784 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
3788 mpfr_nextbelow (result->value.real);
3789 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
3792 mpfr_set_emin (emin);
3793 mpfr_set_emax (emax);
3795 /* Only NaN can occur. Do not use range check as it gives an
3796 error for denormal numbers. */
3797 if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
3799 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
3800 gfc_free_expr (result);
3801 return &gfc_bad_expr;
3809 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
3811 gfc_expr *itrunc, *result;
3814 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
3816 return &gfc_bad_expr;
3818 if (e->expr_type != EXPR_CONSTANT)
3821 itrunc = gfc_copy_expr (e);
3822 mpfr_round (itrunc->value.real, e->value.real);
3824 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
3825 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
3827 gfc_free_expr (itrunc);
3829 return range_check (result, name);
3834 gfc_simplify_new_line (gfc_expr *e)
3838 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
3839 result->value.character.string[0] = '\n';
3846 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
3848 return simplify_nint ("NINT", e, k);
3853 gfc_simplify_idnint (gfc_expr *e)
3855 return simplify_nint ("IDNINT", e, NULL);
3860 gfc_simplify_not (gfc_expr *e)
3864 if (e->expr_type != EXPR_CONSTANT)
3867 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3868 mpz_com (result->value.integer, e->value.integer);
3870 return range_check (result, "NOT");
3875 gfc_simplify_null (gfc_expr *mold)
3881 result = gfc_copy_expr (mold);
3882 result->expr_type = EXPR_NULL;
3885 result = gfc_get_null_expr (NULL);
3892 gfc_simplify_num_images (void)
3896 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3898 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3899 return &gfc_bad_expr;
3902 /* FIXME: gfc_current_locus is wrong. */
3903 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3904 &gfc_current_locus);
3905 mpz_set_si (result->value.integer, 1);
3911 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3916 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3919 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3924 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
3925 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3926 return range_check (result, "OR");
3929 return gfc_get_logical_expr (kind, &x->where,
3930 x->value.logical || y->value.logical);
3938 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
3941 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
3943 if (!is_constant_array_expr(array)
3944 || !is_constant_array_expr(vector)
3945 || (!gfc_is_constant_expr (mask)
3946 && !is_constant_array_expr(mask)))
3949 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
3951 array_ctor = gfc_constructor_first (array->value.constructor);
3952 vector_ctor = vector
3953 ? gfc_constructor_first (vector->value.constructor)
3956 if (mask->expr_type == EXPR_CONSTANT
3957 && mask->value.logical)
3959 /* Copy all elements of ARRAY to RESULT. */
3962 gfc_constructor_append_expr (&result->value.constructor,
3963 gfc_copy_expr (array_ctor->expr),
3966 array_ctor = gfc_constructor_next (array_ctor);
3967 vector_ctor = gfc_constructor_next (vector_ctor);
3970 else if (mask->expr_type == EXPR_ARRAY)
3972 /* Copy only those elements of ARRAY to RESULT whose
3973 MASK equals .TRUE.. */
3974 mask_ctor = gfc_constructor_first (mask->value.constructor);
3977 if (mask_ctor->expr->value.logical)
3979 gfc_constructor_append_expr (&result->value.constructor,
3980 gfc_copy_expr (array_ctor->expr),
3982 vector_ctor = gfc_constructor_next (vector_ctor);
3985 array_ctor = gfc_constructor_next (array_ctor);
3986 mask_ctor = gfc_constructor_next (mask_ctor);
3990 /* Append any left-over elements from VECTOR to RESULT. */
3993 gfc_constructor_append_expr (&result->value.constructor,
3994 gfc_copy_expr (vector_ctor->expr),
3996 vector_ctor = gfc_constructor_next (vector_ctor);
3999 result->shape = gfc_get_shape (1);
4000 gfc_array_size (result, &result->shape[0]);
4002 if (array->ts.type == BT_CHARACTER)
4003 result->ts.u.cl = array->ts.u.cl;
4010 gfc_simplify_precision (gfc_expr *e)
4012 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4013 return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
4014 gfc_real_kinds[i].precision);
4019 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
4023 if (!is_constant_array_expr (array)
4024 || !gfc_is_constant_expr (dim))
4028 && !is_constant_array_expr (mask)
4029 && mask->expr_type != EXPR_CONSTANT)
4032 result = transformational_result (array, dim, array->ts.type,
4033 array->ts.kind, &array->where);
4034 init_result_expr (result, 1, NULL);
4036 return !dim || array->rank == 1 ?
4037 simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
4038 simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
4043 gfc_simplify_radix (gfc_expr *e)
4046 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4051 i = gfc_integer_kinds[i].radix;
4055 i = gfc_real_kinds[i].radix;
4062 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4067 gfc_simplify_range (gfc_expr *e)
4070 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4075 i = gfc_integer_kinds[i].range;
4080 i = gfc_real_kinds[i].range;
4087 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4092 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
4094 gfc_expr *result = NULL;
4097 if (e->ts.type == BT_COMPLEX)
4098 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4100 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
4103 return &gfc_bad_expr;
4105 if (e->expr_type != EXPR_CONSTANT)
4108 if (convert_boz (e, kind) == &gfc_bad_expr)
4109 return &gfc_bad_expr;
4111 result = gfc_convert_constant (e, BT_REAL, kind);
4112 if (result == &gfc_bad_expr)
4113 return &gfc_bad_expr;
4115 return range_check (result, "REAL");
4120 gfc_simplify_realpart (gfc_expr *e)
4124 if (e->expr_type != EXPR_CONSTANT)
4127 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
4128 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
4130 return range_check (result, "REALPART");
4134 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
4137 int i, j, len, ncop, nlen;
4139 bool have_length = false;
4141 /* If NCOPIES isn't a constant, there's nothing we can do. */
4142 if (n->expr_type != EXPR_CONSTANT)
4145 /* If NCOPIES is negative, it's an error. */
4146 if (mpz_sgn (n->value.integer) < 0)
4148 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4150 return &gfc_bad_expr;
4153 /* If we don't know the character length, we can do no more. */
4154 if (e->ts.u.cl && e->ts.u.cl->length
4155 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4157 len = mpz_get_si (e->ts.u.cl->length->value.integer);
4160 else if (e->expr_type == EXPR_CONSTANT
4161 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
4163 len = e->value.character.length;
4168 /* If the source length is 0, any value of NCOPIES is valid
4169 and everything behaves as if NCOPIES == 0. */
4172 mpz_set_ui (ncopies, 0);
4174 mpz_set (ncopies, n->value.integer);
4176 /* Check that NCOPIES isn't too large. */
4182 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
4184 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4188 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4189 e->ts.u.cl->length->value.integer);
4193 mpz_init_set_si (mlen, len);
4194 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4198 /* The check itself. */
4199 if (mpz_cmp (ncopies, max) > 0)
4202 mpz_clear (ncopies);
4203 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4205 return &gfc_bad_expr;
4210 mpz_clear (ncopies);
4212 /* For further simplification, we need the character string to be
4214 if (e->expr_type != EXPR_CONSTANT)
4218 (e->ts.u.cl->length &&
4219 mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
4221 const char *res = gfc_extract_int (n, &ncop);
4222 gcc_assert (res == NULL);
4227 len = e->value.character.length;
4230 result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
4233 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
4235 len = e->value.character.length;
4238 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
4239 for (i = 0; i < ncop; i++)
4240 for (j = 0; j < len; j++)
4241 result->value.character.string[j+i*len]= e->value.character.string[j];
4243 result->value.character.string[nlen] = '\0'; /* For debugger */
4248 /* This one is a bear, but mainly has to do with shuffling elements. */
4251 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4252 gfc_expr *pad, gfc_expr *order_exp)
4254 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4255 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
4259 gfc_expr *e, *result;
4261 /* Check that argument expression types are OK. */
4262 if (!is_constant_array_expr (source)
4263 || !is_constant_array_expr (shape_exp)
4264 || !is_constant_array_expr (pad)
4265 || !is_constant_array_expr (order_exp))
4268 /* Proceed with simplification, unpacking the array. */
4275 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
4279 gfc_extract_int (e, &shape[rank]);
4281 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
4282 gcc_assert (shape[rank] >= 0);
4287 gcc_assert (rank > 0);
4289 /* Now unpack the order array if present. */
4290 if (order_exp == NULL)
4292 for (i = 0; i < rank; i++)
4297 for (i = 0; i < rank; i++)
4300 for (i = 0; i < rank; i++)
4302 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
4305 gfc_extract_int (e, &order[i]);
4307 gcc_assert (order[i] >= 1 && order[i] <= rank);
4309 gcc_assert (x[order[i]] == 0);
4314 /* Count the elements in the source and padding arrays. */
4319 gfc_array_size (pad, &size);
4320 npad = mpz_get_ui (size);
4324 gfc_array_size (source, &size);
4325 nsource = mpz_get_ui (size);
4328 /* If it weren't for that pesky permutation we could just loop
4329 through the source and round out any shortage with pad elements.
4330 But no, someone just had to have the compiler do something the
4331 user should be doing. */
4333 for (i = 0; i < rank; i++)
4336 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4338 result->rank = rank;
4339 result->shape = gfc_get_shape (rank);
4340 for (i = 0; i < rank; i++)
4341 mpz_init_set_ui (result->shape[i], shape[i]);
4343 while (nsource > 0 || npad > 0)
4345 /* Figure out which element to extract. */
4346 mpz_set_ui (index, 0);
4348 for (i = rank - 1; i >= 0; i--)
4350 mpz_add_ui (index, index, x[order[i]]);
4352 mpz_mul_ui (index, index, shape[order[i - 1]]);
4355 if (mpz_cmp_ui (index, INT_MAX) > 0)
4356 gfc_internal_error ("Reshaped array too large at %C");
4358 j = mpz_get_ui (index);
4361 e = gfc_constructor_lookup_expr (source->value.constructor, j);
4364 gcc_assert (npad > 0);
4368 e = gfc_constructor_lookup_expr (pad->value.constructor, j);
4372 gfc_constructor_append_expr (&result->value.constructor,
4373 gfc_copy_expr (e), &e->where);
4375 /* Calculate the next element. */
4379 if (++x[i] < shape[i])
4395 gfc_simplify_rrspacing (gfc_expr *x)
4401 if (x->expr_type != EXPR_CONSTANT)
4404 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4406 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4407 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4409 /* Special case x = -0 and 0. */
4410 if (mpfr_sgn (result->value.real) == 0)
4412 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4416 /* | x * 2**(-e) | * 2**p. */
4417 e = - (long int) mpfr_get_exp (x->value.real);
4418 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
4420 p = (long int) gfc_real_kinds[i].digits;
4421 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
4423 return range_check (result, "RRSPACING");
4428 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
4430 int k, neg_flag, power, exp_range;
4431 mpfr_t scale, radix;
4434 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4437 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4439 if (mpfr_sgn (x->value.real) == 0)
4441 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4445 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4447 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
4449 /* This check filters out values of i that would overflow an int. */
4450 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
4451 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
4453 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
4454 gfc_free_expr (result);
4455 return &gfc_bad_expr;
4458 /* Compute scale = radix ** power. */
4459 power = mpz_get_si (i->value.integer);
4469 gfc_set_model_kind (x->ts.kind);
4472 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
4473 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
4476 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
4478 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
4480 mpfr_clears (scale, radix, NULL);
4482 return range_check (result, "SCALE");
4486 /* Variants of strspn and strcspn that operate on wide characters. */
4489 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
4492 const gfc_char_t *c;
4496 for (c = s2; *c; c++)
4510 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
4513 const gfc_char_t *c;
4517 for (c = s2; *c; c++)
4532 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
4537 size_t indx, len, lenc;
4538 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
4541 return &gfc_bad_expr;
4543 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
4546 if (b != NULL && b->value.logical != 0)
4551 len = e->value.character.length;
4552 lenc = c->value.character.length;
4554 if (len == 0 || lenc == 0)
4562 indx = wide_strcspn (e->value.character.string,
4563 c->value.character.string) + 1;
4570 for (indx = len; indx > 0; indx--)
4572 for (i = 0; i < lenc; i++)
4574 if (c->value.character.string[i]
4575 == e->value.character.string[indx - 1])
4584 result = gfc_get_int_expr (k, &e->where, indx);
4585 return range_check (result, "SCAN");
4590 gfc_simplify_selected_char_kind (gfc_expr *e)
4594 if (e->expr_type != EXPR_CONSTANT)
4597 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
4598 || gfc_compare_with_Cstring (e, "default", false) == 0)
4600 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
4605 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4610 gfc_simplify_selected_int_kind (gfc_expr *e)
4614 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
4619 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
4620 if (gfc_integer_kinds[i].range >= range
4621 && gfc_integer_kinds[i].kind < kind)
4622 kind = gfc_integer_kinds[i].kind;
4624 if (kind == INT_MAX)
4627 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4632 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
4634 int range, precision, radix, i, kind, found_precision, found_range,
4636 locus *loc = &gfc_current_locus;
4642 if (p->expr_type != EXPR_CONSTANT
4643 || gfc_extract_int (p, &precision) != NULL)
4652 if (q->expr_type != EXPR_CONSTANT
4653 || gfc_extract_int (q, &range) != NULL)
4664 if (rdx->expr_type != EXPR_CONSTANT
4665 || gfc_extract_int (rdx, &radix) != NULL)
4673 found_precision = 0;
4677 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
4679 if (gfc_real_kinds[i].precision >= precision)
4680 found_precision = 1;
4682 if (gfc_real_kinds[i].range >= range)
4685 if (gfc_real_kinds[i].radix >= radix)
4688 if (gfc_real_kinds[i].precision >= precision
4689 && gfc_real_kinds[i].range >= range
4690 && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
4691 kind = gfc_real_kinds[i].kind;
4694 if (kind == INT_MAX)
4696 if (found_radix && found_range && !found_precision)
4698 else if (found_radix && found_precision && !found_range)
4700 else if (found_radix && !found_precision && !found_range)
4702 else if (found_radix)
4708 return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
4713 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
4716 mpfr_t exp, absv, log2, pow2, frac;
4719 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4722 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4724 if (mpfr_sgn (x->value.real) == 0)
4726 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4730 gfc_set_model_kind (x->ts.kind);
4737 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
4738 mpfr_log2 (log2, absv, GFC_RND_MODE);
4740 mpfr_trunc (log2, log2);
4741 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
4743 /* Old exponent value, and fraction. */
4744 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
4746 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
4749 exp2 = (unsigned long) mpz_get_d (i->value.integer);
4750 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
4752 mpfr_clears (absv, log2, pow2, frac, NULL);
4754 return range_check (result, "SET_EXPONENT");
4759 gfc_simplify_shape (gfc_expr *source)
4761 mpz_t shape[GFC_MAX_DIMENSIONS];
4762 gfc_expr *result, *e, *f;
4767 if (source->rank == 0)
4768 return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4771 result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4774 if (source->expr_type == EXPR_VARIABLE)
4776 ar = gfc_find_array_ref (source);
4777 t = gfc_array_ref_shape (ar, shape);
4779 else if (source->shape)
4782 for (n = 0; n < source->rank; n++)
4784 mpz_init (shape[n]);
4785 mpz_set (shape[n], source->shape[n]);
4791 for (n = 0; n < source->rank; n++)
4793 e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4798 mpz_set (e->value.integer, shape[n]);
4799 mpz_clear (shape[n]);
4803 mpz_set_ui (e->value.integer, n + 1);
4805 f = gfc_simplify_size (source, e, NULL);
4809 gfc_free_expr (result);
4816 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
4824 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4828 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4831 return &gfc_bad_expr;
4833 /* For unary operations, the size of the result is given by the size
4834 of the operand. For binary ones, it's the size of the first operand
4835 unless it is scalar, then it is the size of the second. */
4836 if (array->expr_type == EXPR_OP && !array->value.op.uop)
4838 gfc_expr* replacement;
4839 gfc_expr* simplified;
4841 switch (array->value.op.op)
4843 /* Unary operations. */
4845 case INTRINSIC_UPLUS:
4846 case INTRINSIC_UMINUS:
4847 replacement = array->value.op.op1;
4850 /* Binary operations. If any one of the operands is scalar, take
4851 the other one's size. If both of them are arrays, it does not
4852 matter -- try to find one with known shape, if possible. */
4854 if (array->value.op.op1->rank == 0)
4855 replacement = array->value.op.op2;
4856 else if (array->value.op.op2->rank == 0)
4857 replacement = array->value.op.op1;
4860 simplified = gfc_simplify_size (array->value.op.op1, dim, kind);
4864 replacement = array->value.op.op2;
4869 /* Try to reduce it directly if possible. */
4870 simplified = gfc_simplify_size (replacement, dim, kind);
4872 /* Otherwise, we build a new SIZE call. This is hopefully at least
4873 simpler than the original one. */
4875 simplified = gfc_build_intrinsic_call ("size", array->where, 3,
4876 gfc_copy_expr (replacement),
4877 gfc_copy_expr (dim),
4878 gfc_copy_expr (kind));
4885 if (gfc_array_size (array, &size) == FAILURE)
4890 if (dim->expr_type != EXPR_CONSTANT)
4893 d = mpz_get_ui (dim->value.integer) - 1;
4894 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4898 return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
4903 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4907 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4910 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4915 mpz_abs (result->value.integer, x->value.integer);
4916 if (mpz_sgn (y->value.integer) < 0)
4917 mpz_neg (result->value.integer, result->value.integer);
4921 if (gfc_option.flag_sign_zero)
4922 mpfr_copysign (result->value.real, x->value.real, y->value.real,
4925 mpfr_setsign (result->value.real, x->value.real,
4926 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
4930 gfc_internal_error ("Bad type in gfc_simplify_sign");
4938 gfc_simplify_sin (gfc_expr *x)
4942 if (x->expr_type != EXPR_CONSTANT)
4945 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4950 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4954 gfc_set_model (x->value.real);
4955 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4959 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4962 return range_check (result, "SIN");
4967 gfc_simplify_sinh (gfc_expr *x)
4971 if (x->expr_type != EXPR_CONSTANT)
4974 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4979 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4983 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4990 return range_check (result, "SINH");
4994 /* The argument is always a double precision real that is converted to
4995 single precision. TODO: Rounding! */
4998 gfc_simplify_sngl (gfc_expr *a)
5002 if (a->expr_type != EXPR_CONSTANT)
5005 result = gfc_real2real (a, gfc_default_real_kind);
5006 return range_check (result, "SNGL");
5011 gfc_simplify_spacing (gfc_expr *x)
5017 if (x->expr_type != EXPR_CONSTANT)
5020 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5022 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5024 /* Special case x = 0 and -0. */
5025 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5026 if (mpfr_sgn (result->value.real) == 0)
5028 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5032 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
5033 are the radix, exponent of x, and precision. This excludes the
5034 possibility of subnormal numbers. Fortran 2003 states the result is
5035 b**max(e - p, emin - 1). */
5037 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
5038 en = (long int) gfc_real_kinds[i].min_exponent - 1;
5039 en = en > ep ? en : ep;
5041 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
5042 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
5044 return range_check (result, "SPACING");
5049 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
5051 gfc_expr *result = 0L;
5052 int i, j, dim, ncopies;
5055 if ((!gfc_is_constant_expr (source)
5056 && !is_constant_array_expr (source))
5057 || !gfc_is_constant_expr (dim_expr)
5058 || !gfc_is_constant_expr (ncopies_expr))
5061 gcc_assert (dim_expr->ts.type == BT_INTEGER);
5062 gfc_extract_int (dim_expr, &dim);
5063 dim -= 1; /* zero-base DIM */
5065 gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
5066 gfc_extract_int (ncopies_expr, &ncopies);
5067 ncopies = MAX (ncopies, 0);
5069 /* Do not allow the array size to exceed the limit for an array
5071 if (source->expr_type == EXPR_ARRAY)
5073 if (gfc_array_size (source, &size) == FAILURE)
5074 gfc_internal_error ("Failure getting length of a constant array.");
5077 mpz_init_set_ui (size, 1);
5079 if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
5082 if (source->expr_type == EXPR_CONSTANT)
5084 gcc_assert (dim == 0);
5086 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5089 result->shape = gfc_get_shape (result->rank);
5090 mpz_init_set_si (result->shape[0], ncopies);
5092 for (i = 0; i < ncopies; ++i)
5093 gfc_constructor_append_expr (&result->value.constructor,
5094 gfc_copy_expr (source), NULL);
5096 else if (source->expr_type == EXPR_ARRAY)
5098 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
5099 gfc_constructor *source_ctor;
5101 gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
5102 gcc_assert (dim >= 0 && dim <= source->rank);
5104 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5106 result->rank = source->rank + 1;
5107 result->shape = gfc_get_shape (result->rank);
5109 for (i = 0, j = 0; i < result->rank; ++i)
5112 mpz_init_set (result->shape[i], source->shape[j++]);
5114 mpz_init_set_si (result->shape[i], ncopies);
5116 extent[i] = mpz_get_si (result->shape[i]);
5117 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
5121 for (source_ctor = gfc_constructor_first (source->value.constructor);
5122 source_ctor; source_ctor = gfc_constructor_next (source_ctor))
5124 for (i = 0; i < ncopies; ++i)
5125 gfc_constructor_insert_expr (&result->value.constructor,
5126 gfc_copy_expr (source_ctor->expr),
5127 NULL, offset + i * rstride[dim]);
5129 offset += (dim == 0 ? ncopies : 1);
5133 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5134 Replace NULL with gcc_unreachable() after implementing
5135 gfc_simplify_cshift(). */
5138 if (source->ts.type == BT_CHARACTER)
5139 result->ts.u.cl = source->ts.u.cl;
5146 gfc_simplify_sqrt (gfc_expr *e)
5148 gfc_expr *result = NULL;
5150 if (e->expr_type != EXPR_CONSTANT)
5156 if (mpfr_cmp_si (e->value.real, 0) < 0)
5158 gfc_error ("Argument of SQRT at %L has a negative value",
5160 return &gfc_bad_expr;
5162 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5163 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5167 gfc_set_model (e->value.real);
5169 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5170 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
5174 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
5177 return range_check (result, "SQRT");
5182 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5186 if (!is_constant_array_expr (array)
5187 || !gfc_is_constant_expr (dim))
5191 && !is_constant_array_expr (mask)
5192 && mask->expr_type != EXPR_CONSTANT)
5195 result = transformational_result (array, dim, array->ts.type,
5196 array->ts.kind, &array->where);
5197 init_result_expr (result, 0, NULL);
5199 return !dim || array->rank == 1 ?
5200 simplify_transformation_to_scalar (result, array, mask, gfc_add) :
5201 simplify_transformation_to_array (result, array, dim, mask, gfc_add);
5206 gfc_simplify_tan (gfc_expr *x)
5210 if (x->expr_type != EXPR_CONSTANT)
5213 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5218 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
5222 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5229 return range_check (result, "TAN");
5234 gfc_simplify_tanh (gfc_expr *x)
5238 if (x->expr_type != EXPR_CONSTANT)
5241 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5246 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
5250 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5257 return range_check (result, "TANH");
5262 gfc_simplify_tiny (gfc_expr *e)
5267 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5269 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5270 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5277 gfc_simplify_trailz (gfc_expr *e)
5279 unsigned long tz, bs;
5282 if (e->expr_type != EXPR_CONSTANT)
5285 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5286 bs = gfc_integer_kinds[i].bit_size;
5287 tz = mpz_scan1 (e->value.integer, 0);
5289 return gfc_get_int_expr (gfc_default_integer_kind,
5290 &e->where, MIN (tz, bs));
5295 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5298 gfc_expr *mold_element;
5301 size_t result_elt_size;
5304 unsigned char *buffer;
5306 if (!gfc_is_constant_expr (source)
5307 || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
5308 || !gfc_is_constant_expr (size))
5311 if (source->expr_type == EXPR_FUNCTION)
5314 /* Calculate the size of the source. */
5315 if (source->expr_type == EXPR_ARRAY
5316 && gfc_array_size (source, &tmp) == FAILURE)
5317 gfc_internal_error ("Failure getting length of a constant array.");
5319 source_size = gfc_target_expr_size (source);
5321 /* Create an empty new expression with the appropriate characteristics. */
5322 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
5324 result->ts = mold->ts;
5326 mold_element = mold->expr_type == EXPR_ARRAY
5327 ? gfc_constructor_first (mold->value.constructor)->expr
5330 /* Set result character length, if needed. Note that this needs to be
5331 set even for array expressions, in order to pass this information into
5332 gfc_target_interpret_expr. */
5333 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
5334 result->value.character.length = mold_element->value.character.length;
5336 /* Set the number of elements in the result, and determine its size. */
5337 result_elt_size = gfc_target_expr_size (mold_element);
5338 if (result_elt_size == 0)
5340 gfc_free_expr (result);
5344 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
5348 result->expr_type = EXPR_ARRAY;
5352 result_length = (size_t)mpz_get_ui (size->value.integer);
5355 result_length = source_size / result_elt_size;
5356 if (result_length * result_elt_size < source_size)
5360 result->shape = gfc_get_shape (1);
5361 mpz_init_set_ui (result->shape[0], result_length);
5363 result_size = result_length * result_elt_size;
5368 result_size = result_elt_size;
5371 if (gfc_option.warn_surprising && source_size < result_size)
5372 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
5373 "source size %ld < result size %ld", &source->where,
5374 (long) source_size, (long) result_size);
5376 /* Allocate the buffer to store the binary version of the source. */
5377 buffer_size = MAX (source_size, result_size);
5378 buffer = (unsigned char*)alloca (buffer_size);
5379 memset (buffer, 0, buffer_size);
5381 /* Now write source to the buffer. */
5382 gfc_target_encode_expr (source, buffer, buffer_size);
5384 /* And read the buffer back into the new expression. */
5385 gfc_target_interpret_expr (buffer, buffer_size, result);
5392 gfc_simplify_transpose (gfc_expr *matrix)
5394 int row, matrix_rows, col, matrix_cols;
5397 if (!is_constant_array_expr (matrix))
5400 gcc_assert (matrix->rank == 2);
5402 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
5405 result->shape = gfc_get_shape (result->rank);
5406 mpz_set (result->shape[0], matrix->shape[1]);
5407 mpz_set (result->shape[1], matrix->shape[0]);
5409 if (matrix->ts.type == BT_CHARACTER)
5410 result->ts.u.cl = matrix->ts.u.cl;
5412 matrix_rows = mpz_get_si (matrix->shape[0]);
5413 matrix_cols = mpz_get_si (matrix->shape[1]);
5414 for (row = 0; row < matrix_rows; ++row)
5415 for (col = 0; col < matrix_cols; ++col)
5417 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
5418 col * matrix_rows + row);
5419 gfc_constructor_insert_expr (&result->value.constructor,
5420 gfc_copy_expr (e), &matrix->where,
5421 row * matrix_cols + col);
5429 gfc_simplify_trim (gfc_expr *e)
5432 int count, i, len, lentrim;
5434 if (e->expr_type != EXPR_CONSTANT)
5437 len = e->value.character.length;
5438 for (count = 0, i = 1; i <= len; ++i)
5440 if (e->value.character.string[len - i] == ' ')
5446 lentrim = len - count;
5448 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
5449 for (i = 0; i < lentrim; i++)
5450 result->value.character.string[i] = e->value.character.string[i];
5457 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
5462 gfc_constructor *sub_cons;
5466 if (!is_constant_array_expr (sub))
5467 goto not_implemented; /* return NULL;*/
5469 /* Follow any component references. */
5470 as = coarray->symtree->n.sym->as;
5471 for (ref = coarray->ref; ref; ref = ref->next)
5472 if (ref->type == REF_COMPONENT)
5475 if (as->type == AS_DEFERRED)
5476 goto not_implemented; /* return NULL;*/
5478 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
5479 the cosubscript addresses the first image. */
5481 sub_cons = gfc_constructor_first (sub->value.constructor);
5484 for (d = 1; d <= as->corank; d++)
5489 if (sub_cons == NULL)
5491 gfc_error ("Too few elements in expression for SUB= argument at %L",
5493 return &gfc_bad_expr;
5496 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
5498 if (ca_bound == NULL)
5499 goto not_implemented; /* return NULL */
5501 if (ca_bound == &gfc_bad_expr)
5504 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
5508 gfc_free_expr (ca_bound);
5509 sub_cons = gfc_constructor_next (sub_cons);
5513 first_image = false;
5517 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
5518 "SUB has %ld and COARRAY lower bound is %ld)",
5520 mpz_get_si (sub_cons->expr->value.integer),
5521 mpz_get_si (ca_bound->value.integer));
5522 gfc_free_expr (ca_bound);
5523 return &gfc_bad_expr;
5526 gfc_free_expr (ca_bound);
5528 /* Check whether upperbound is valid for the multi-images case. */
5531 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
5533 if (ca_bound == &gfc_bad_expr)
5536 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
5537 && mpz_cmp (ca_bound->value.integer,
5538 sub_cons->expr->value.integer) < 0)
5540 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
5541 "SUB has %ld and COARRAY upper bound is %ld)",
5543 mpz_get_si (sub_cons->expr->value.integer),
5544 mpz_get_si (ca_bound->value.integer));
5545 gfc_free_expr (ca_bound);
5546 return &gfc_bad_expr;
5550 gfc_free_expr (ca_bound);
5553 sub_cons = gfc_constructor_next (sub_cons);
5556 if (sub_cons != NULL)
5558 gfc_error ("Too many elements in expression for SUB= argument at %L",
5560 return &gfc_bad_expr;
5563 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5564 &gfc_current_locus);
5566 mpz_set_si (result->value.integer, 1);
5568 mpz_set_si (result->value.integer, 0);
5573 gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
5574 "cobounds at %L", &coarray->where);
5575 return &gfc_bad_expr;
5580 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
5586 if (coarray == NULL)
5589 /* FIXME: gfc_current_locus is wrong. */
5590 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5591 &gfc_current_locus);
5592 mpz_set_si (result->value.integer, 1);
5596 gcc_assert (coarray->expr_type == EXPR_VARIABLE);
5598 /* Follow any component references. */
5599 as = coarray->symtree->n.sym->as;
5600 for (ref = coarray->ref; ref; ref = ref->next)
5601 if (ref->type == REF_COMPONENT)
5604 if (as->type == AS_DEFERRED)
5605 goto not_implemented; /* return NULL;*/
5609 /* Multi-dimensional bounds. */
5610 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
5613 /* Simplify the bounds for each dimension. */
5614 for (d = 0; d < as->corank; d++)
5616 bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
5618 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
5622 for (j = 0; j < d; j++)
5623 gfc_free_expr (bounds[j]);
5624 if (bounds[d] == NULL)
5625 goto not_implemented;
5630 /* Allocate the result expression. */
5631 e = gfc_get_expr ();
5632 e->where = coarray->where;
5633 e->expr_type = EXPR_ARRAY;
5634 e->ts.type = BT_INTEGER;
5635 e->ts.kind = gfc_default_integer_kind;
5638 e->shape = gfc_get_shape (1);
5639 mpz_init_set_ui (e->shape[0], as->corank);
5641 /* Create the constructor for this array. */
5642 for (d = 0; d < as->corank; d++)
5643 gfc_constructor_append_expr (&e->value.constructor,
5644 bounds[d], &e->where);
5651 /* A DIM argument is specified. */
5652 if (dim->expr_type != EXPR_CONSTANT)
5653 goto not_implemented; /*return NULL;*/
5655 d = mpz_get_si (dim->value.integer);
5657 if (d < 1 || d > as->corank)
5659 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
5660 return &gfc_bad_expr;
5663 /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
5664 e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
5668 goto not_implemented;
5672 gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
5673 "cobounds at %L", &coarray->where);
5674 return &gfc_bad_expr;
5679 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5681 return simplify_bound (array, dim, kind, 1);
5685 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5688 /* return simplify_cobound (array, dim, kind, 1);*/
5690 e = simplify_cobound (array, dim, kind, 1);
5694 gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
5695 "cobounds at %L", &array->where);
5696 return &gfc_bad_expr;
5701 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
5703 gfc_expr *result, *e;
5704 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
5706 if (!is_constant_array_expr (vector)
5707 || !is_constant_array_expr (mask)
5708 || (!gfc_is_constant_expr (field)
5709 && !is_constant_array_expr(field)))
5712 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
5714 result->rank = mask->rank;
5715 result->shape = gfc_copy_shape (mask->shape, mask->rank);
5717 if (vector->ts.type == BT_CHARACTER)
5718 result->ts.u.cl = vector->ts.u.cl;
5720 vector_ctor = gfc_constructor_first (vector->value.constructor);
5721 mask_ctor = gfc_constructor_first (mask->value.constructor);
5723 = field->expr_type == EXPR_ARRAY
5724 ? gfc_constructor_first (field->value.constructor)
5729 if (mask_ctor->expr->value.logical)
5731 gcc_assert (vector_ctor);
5732 e = gfc_copy_expr (vector_ctor->expr);
5733 vector_ctor = gfc_constructor_next (vector_ctor);
5735 else if (field->expr_type == EXPR_ARRAY)
5736 e = gfc_copy_expr (field_ctor->expr);
5738 e = gfc_copy_expr (field);
5740 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5742 mask_ctor = gfc_constructor_next (mask_ctor);
5743 field_ctor = gfc_constructor_next (field_ctor);
5751 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
5755 size_t index, len, lenset;
5757 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
5760 return &gfc_bad_expr;
5762 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
5765 if (b != NULL && b->value.logical != 0)
5770 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
5772 len = s->value.character.length;
5773 lenset = set->value.character.length;
5777 mpz_set_ui (result->value.integer, 0);
5785 mpz_set_ui (result->value.integer, 1);
5789 index = wide_strspn (s->value.character.string,
5790 set->value.character.string) + 1;
5799 mpz_set_ui (result->value.integer, len);
5802 for (index = len; index > 0; index --)
5804 for (i = 0; i < lenset; i++)
5806 if (s->value.character.string[index - 1]
5807 == set->value.character.string[i])
5815 mpz_set_ui (result->value.integer, index);
5821 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
5826 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5829 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
5834 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
5835 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
5836 return range_check (result, "XOR");
5839 return gfc_get_logical_expr (kind, &x->where,
5840 (x->value.logical && !y->value.logical)
5841 || (!x->value.logical && y->value.logical));
5849 /****************** Constant simplification *****************/
5851 /* Master function to convert one constant to another. While this is
5852 used as a simplification function, it requires the destination type
5853 and kind information which is supplied by a special case in
5857 gfc_convert_constant (gfc_expr *e, bt type, int kind)
5859 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
5874 f = gfc_int2complex;
5894 f = gfc_real2complex;
5905 f = gfc_complex2int;
5908 f = gfc_complex2real;
5911 f = gfc_complex2complex;
5937 f = gfc_hollerith2int;
5941 f = gfc_hollerith2real;
5945 f = gfc_hollerith2complex;
5949 f = gfc_hollerith2character;
5953 f = gfc_hollerith2logical;
5963 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
5968 switch (e->expr_type)
5971 result = f (e, kind);
5973 return &gfc_bad_expr;
5977 if (!gfc_is_constant_expr (e))
5980 result = gfc_get_array_expr (type, kind, &e->where);
5981 result->shape = gfc_copy_shape (e->shape, e->rank);
5982 result->rank = e->rank;
5984 for (c = gfc_constructor_first (e->value.constructor);
5985 c; c = gfc_constructor_next (c))
5988 if (c->iterator == NULL)
5989 tmp = f (c->expr, kind);
5992 g = gfc_convert_constant (c->expr, type, kind);
5993 if (g == &gfc_bad_expr)
5995 gfc_free_expr (result);
6003 gfc_free_expr (result);
6007 gfc_constructor_append_expr (&result->value.constructor,
6021 /* Function for converting character constants. */
6023 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
6028 if (!gfc_is_constant_expr (e))
6031 if (e->expr_type == EXPR_CONSTANT)
6033 /* Simple case of a scalar. */
6034 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
6036 return &gfc_bad_expr;
6038 result->value.character.length = e->value.character.length;
6039 result->value.character.string
6040 = gfc_get_wide_string (e->value.character.length + 1);
6041 memcpy (result->value.character.string, e->value.character.string,
6042 (e->value.character.length + 1) * sizeof (gfc_char_t));
6044 /* Check we only have values representable in the destination kind. */
6045 for (i = 0; i < result->value.character.length; i++)
6046 if (!gfc_check_character_range (result->value.character.string[i],
6049 gfc_error ("Character '%s' in string at %L cannot be converted "
6050 "into character kind %d",
6051 gfc_print_wide_char (result->value.character.string[i]),
6053 return &gfc_bad_expr;
6058 else if (e->expr_type == EXPR_ARRAY)
6060 /* For an array constructor, we convert each constructor element. */
6063 result = gfc_get_array_expr (type, kind, &e->where);
6064 result->shape = gfc_copy_shape (e->shape, e->rank);
6065 result->rank = e->rank;
6066 result->ts.u.cl = e->ts.u.cl;
6068 for (c = gfc_constructor_first (e->value.constructor);
6069 c; c = gfc_constructor_next (c))
6071 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
6072 if (tmp == &gfc_bad_expr)
6074 gfc_free_expr (result);
6075 return &gfc_bad_expr;
6080 gfc_free_expr (result);
6084 gfc_constructor_append_expr (&result->value.constructor,