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 switch (gfc_range_check (result))
82 gfc_error ("Result of %s overflows its kind at %L", name,
87 gfc_error ("Result of %s underflows its kind at %L", name,
92 gfc_error ("Result of %s is NaN at %L", name, &result->where);
96 gfc_error ("Result of %s gives range error for its kind at %L", name,
101 gfc_free_expr (result);
102 return &gfc_bad_expr;
106 /* A helper function that gets an optional and possibly missing
107 kind parameter. Returns the kind, -1 if something went wrong. */
110 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
117 if (k->expr_type != EXPR_CONSTANT)
119 gfc_error ("KIND parameter of %s at %L must be an initialization "
120 "expression", name, &k->where);
124 if (gfc_extract_int (k, &kind) != NULL
125 || gfc_validate_kind (type, kind, true) < 0)
127 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
135 /* Converts an mpz_t signed variable into an unsigned one, assuming
136 two's complement representations and a binary width of bitsize.
137 The conversion is a no-op unless x is negative; otherwise, it can
138 be accomplished by masking out the high bits. */
141 convert_mpz_to_unsigned (mpz_t x, int bitsize)
147 /* Confirm that no bits above the signed range are unset. */
148 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
150 mpz_init_set_ui (mask, 1);
151 mpz_mul_2exp (mask, mask, bitsize);
152 mpz_sub_ui (mask, mask, 1);
154 mpz_and (x, x, mask);
160 /* Confirm that no bits above the signed range are set. */
161 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
166 /* Converts an mpz_t unsigned variable into a signed one, assuming
167 two's complement representations and a binary width of bitsize.
168 If the bitsize-1 bit is set, this is taken as a sign bit and
169 the number is converted to the corresponding negative number. */
172 convert_mpz_to_signed (mpz_t x, int bitsize)
176 /* Confirm that no bits above the unsigned range are set. */
177 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
179 if (mpz_tstbit (x, bitsize - 1) == 1)
181 mpz_init_set_ui (mask, 1);
182 mpz_mul_2exp (mask, mask, bitsize);
183 mpz_sub_ui (mask, mask, 1);
185 /* We negate the number by hand, zeroing the high bits, that is
186 make it the corresponding positive number, and then have it
187 negated by GMP, giving the correct representation of the
190 mpz_add_ui (x, x, 1);
191 mpz_and (x, x, mask);
200 /* In-place convert BOZ to REAL of the specified kind. */
203 convert_boz (gfc_expr *x, int kind)
205 if (x && x->ts.type == BT_INTEGER && x->is_boz)
212 if (!gfc_convert_boz (x, &ts))
213 return &gfc_bad_expr;
220 /* Test that the expression is an constant array. */
223 is_constant_array_expr (gfc_expr *e)
230 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
233 for (c = gfc_constructor_first (e->value.constructor);
234 c; c = gfc_constructor_next (c))
235 if (c->expr->expr_type != EXPR_CONSTANT)
242 /* Initialize a transformational result expression with a given value. */
245 init_result_expr (gfc_expr *e, int init, gfc_expr *array)
247 if (e && e->expr_type == EXPR_ARRAY)
249 gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
252 init_result_expr (ctor->expr, init, array);
253 ctor = gfc_constructor_next (ctor);
256 else if (e && e->expr_type == EXPR_CONSTANT)
258 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
265 e->value.logical = (init ? 1 : 0);
270 mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
271 else if (init == INT_MAX)
272 mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
274 mpz_set_si (e->value.integer, init);
280 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
281 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
283 else if (init == INT_MAX)
284 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
286 mpfr_set_si (e->value.real, init, GFC_RND_MODE);
290 mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
296 gfc_expr *len = gfc_simplify_len (array, NULL);
297 gfc_extract_int (len, &length);
298 string = gfc_get_wide_string (length + 1);
299 gfc_wide_memset (string, 0, length);
301 else if (init == INT_MAX)
303 gfc_expr *len = gfc_simplify_len (array, NULL);
304 gfc_extract_int (len, &length);
305 string = gfc_get_wide_string (length + 1);
306 gfc_wide_memset (string, 255, length);
311 string = gfc_get_wide_string (1);
314 string[length] = '\0';
315 e->value.character.length = length;
316 e->value.character.string = string;
328 /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */
331 compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
332 gfc_expr *matrix_b, int stride_b, int offset_b)
334 gfc_expr *result, *a, *b;
336 result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind,
338 init_result_expr (result, 0, NULL);
340 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
341 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
344 /* Copying of expressions is required as operands are free'd
345 by the gfc_arith routines. */
346 switch (result->ts.type)
349 result = gfc_or (result,
350 gfc_and (gfc_copy_expr (a),
357 result = gfc_add (result,
358 gfc_multiply (gfc_copy_expr (a),
366 offset_a += stride_a;
367 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
369 offset_b += stride_b;
370 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
377 /* Build a result expression for transformational intrinsics,
381 transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
382 int kind, locus* where)
387 if (!dim || array->rank == 1)
388 return gfc_get_constant_expr (type, kind, where);
390 result = gfc_get_array_expr (type, kind, where);
391 result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
392 result->rank = array->rank - 1;
394 /* gfc_array_size() would count the number of elements in the constructor,
395 we have not built those yet. */
397 for (i = 0; i < result->rank; ++i)
398 nelem *= mpz_get_ui (result->shape[i]);
400 for (i = 0; i < nelem; ++i)
402 gfc_constructor_append_expr (&result->value.constructor,
403 gfc_get_constant_expr (type, kind, where),
411 typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
413 /* Wrapper function, implements 'op1 += 1'. Only called if MASK
414 of COUNT intrinsic is .TRUE..
416 Interface and implimentation mimics arith functions as
417 gfc_add, gfc_multiply, etc. */
419 static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2)
423 gcc_assert (op1->ts.type == BT_INTEGER);
424 gcc_assert (op2->ts.type == BT_LOGICAL);
425 gcc_assert (op2->value.logical);
427 result = gfc_copy_expr (op1);
428 mpz_add_ui (result->value.integer, result->value.integer, 1);
436 /* Transforms an ARRAY with operation OP, according to MASK, to a
437 scalar RESULT. E.g. called if
439 REAL, PARAMETER :: array(n, m) = ...
440 REAL, PARAMETER :: s = SUM(array)
442 where OP == gfc_add(). */
445 simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
446 transformational_op op)
449 gfc_constructor *array_ctor, *mask_ctor;
451 /* Shortcut for constant .FALSE. MASK. */
453 && mask->expr_type == EXPR_CONSTANT
454 && !mask->value.logical)
457 array_ctor = gfc_constructor_first (array->value.constructor);
459 if (mask && mask->expr_type == EXPR_ARRAY)
460 mask_ctor = gfc_constructor_first (mask->value.constructor);
464 a = array_ctor->expr;
465 array_ctor = gfc_constructor_next (array_ctor);
467 /* A constant MASK equals .TRUE. here and can be ignored. */
471 mask_ctor = gfc_constructor_next (mask_ctor);
472 if (!m->value.logical)
476 result = op (result, gfc_copy_expr (a));
482 /* Transforms an ARRAY with operation OP, according to MASK, to an
483 array RESULT. E.g. called if
485 REAL, PARAMETER :: array(n, m) = ...
486 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
488 where OP == gfc_multiply(). */
491 simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
492 gfc_expr *mask, transformational_op op)
495 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
496 gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
497 gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
499 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
500 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
501 tmpstride[GFC_MAX_DIMENSIONS];
503 /* Shortcut for constant .FALSE. MASK. */
505 && mask->expr_type == EXPR_CONSTANT
506 && !mask->value.logical)
509 /* Build an indexed table for array element expressions to minimize
510 linked-list traversal. Masked elements are set to NULL. */
511 gfc_array_size (array, &size);
512 arraysize = mpz_get_ui (size);
514 arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
516 array_ctor = gfc_constructor_first (array->value.constructor);
518 if (mask && mask->expr_type == EXPR_ARRAY)
519 mask_ctor = gfc_constructor_first (mask->value.constructor);
521 for (i = 0; i < arraysize; ++i)
523 arrayvec[i] = array_ctor->expr;
524 array_ctor = gfc_constructor_next (array_ctor);
528 if (!mask_ctor->expr->value.logical)
531 mask_ctor = gfc_constructor_next (mask_ctor);
535 /* Same for the result expression. */
536 gfc_array_size (result, &size);
537 resultsize = mpz_get_ui (size);
540 resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
541 result_ctor = gfc_constructor_first (result->value.constructor);
542 for (i = 0; i < resultsize; ++i)
544 resultvec[i] = result_ctor->expr;
545 result_ctor = gfc_constructor_next (result_ctor);
548 gfc_extract_int (dim, &dim_index);
549 dim_index -= 1; /* zero-base index */
553 for (i = 0, n = 0; i < array->rank; ++i)
556 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
559 dim_extent = mpz_get_si (array->shape[i]);
560 dim_stride = tmpstride[i];
564 extent[n] = mpz_get_si (array->shape[i]);
565 sstride[n] = tmpstride[i];
566 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
575 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
577 *dest = op (*dest, gfc_copy_expr (*src));
584 while (!done && count[n] == extent[n])
587 base -= sstride[n] * extent[n];
588 dest -= dstride[n] * extent[n];
591 if (n < result->rank)
602 /* Place updated expression in result constructor. */
603 result_ctor = gfc_constructor_first (result->value.constructor);
604 for (i = 0; i < resultsize; ++i)
606 result_ctor->expr = resultvec[i];
607 result_ctor = gfc_constructor_next (result_ctor);
611 gfc_free (resultvec);
617 /********************** Simplification functions *****************************/
620 gfc_simplify_abs (gfc_expr *e)
624 if (e->expr_type != EXPR_CONSTANT)
630 result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
631 mpz_abs (result->value.integer, e->value.integer);
632 return range_check (result, "IABS");
635 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
636 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
637 return range_check (result, "ABS");
640 gfc_set_model_kind (e->ts.kind);
641 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
642 mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
643 return range_check (result, "CABS");
646 gfc_internal_error ("gfc_simplify_abs(): Bad type");
652 simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
656 bool too_large = false;
658 if (e->expr_type != EXPR_CONSTANT)
661 kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
663 return &gfc_bad_expr;
665 if (mpz_cmp_si (e->value.integer, 0) < 0)
667 gfc_error ("Argument of %s function at %L is negative", name,
669 return &gfc_bad_expr;
672 if (ascii && gfc_option.warn_surprising
673 && mpz_cmp_si (e->value.integer, 127) > 0)
674 gfc_warning ("Argument of %s function at %L outside of range [0,127]",
677 if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
682 mpz_init_set_ui (t, 2);
683 mpz_pow_ui (t, t, 32);
684 mpz_sub_ui (t, t, 1);
685 if (mpz_cmp (e->value.integer, t) > 0)
692 gfc_error ("Argument of %s function at %L is too large for the "
693 "collating sequence of kind %d", name, &e->where, kind);
694 return &gfc_bad_expr;
697 result = gfc_get_character_expr (kind, &e->where, NULL, 1);
698 result->value.character.string[0] = mpz_get_ui (e->value.integer);
705 /* We use the processor's collating sequence, because all
706 systems that gfortran currently works on are ASCII. */
709 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
711 return simplify_achar_char (e, k, "ACHAR", true);
716 gfc_simplify_acos (gfc_expr *x)
720 if (x->expr_type != EXPR_CONSTANT)
726 if (mpfr_cmp_si (x->value.real, 1) > 0
727 || mpfr_cmp_si (x->value.real, -1) < 0)
729 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
731 return &gfc_bad_expr;
733 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
734 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
738 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
739 mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
743 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
746 return range_check (result, "ACOS");
750 gfc_simplify_acosh (gfc_expr *x)
754 if (x->expr_type != EXPR_CONSTANT)
760 if (mpfr_cmp_si (x->value.real, 1) < 0)
762 gfc_error ("Argument of ACOSH at %L must not be less than 1",
764 return &gfc_bad_expr;
767 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
768 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
772 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
773 mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
777 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
780 return range_check (result, "ACOSH");
784 gfc_simplify_adjustl (gfc_expr *e)
790 if (e->expr_type != EXPR_CONSTANT)
793 len = e->value.character.length;
795 for (count = 0, i = 0; i < len; ++i)
797 ch = e->value.character.string[i];
803 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
804 for (i = 0; i < len - count; ++i)
805 result->value.character.string[i] = e->value.character.string[count + i];
812 gfc_simplify_adjustr (gfc_expr *e)
818 if (e->expr_type != EXPR_CONSTANT)
821 len = e->value.character.length;
823 for (count = 0, i = len - 1; i >= 0; --i)
825 ch = e->value.character.string[i];
831 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
832 for (i = 0; i < count; ++i)
833 result->value.character.string[i] = ' ';
835 for (i = count; i < len; ++i)
836 result->value.character.string[i] = e->value.character.string[i - count];
843 gfc_simplify_aimag (gfc_expr *e)
847 if (e->expr_type != EXPR_CONSTANT)
850 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
851 mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
853 return range_check (result, "AIMAG");
858 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
860 gfc_expr *rtrunc, *result;
863 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
865 return &gfc_bad_expr;
867 if (e->expr_type != EXPR_CONSTANT)
870 rtrunc = gfc_copy_expr (e);
871 mpfr_trunc (rtrunc->value.real, e->value.real);
873 result = gfc_real2real (rtrunc, kind);
875 gfc_free_expr (rtrunc);
877 return range_check (result, "AINT");
882 gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
886 if (!is_constant_array_expr (mask)
887 || !gfc_is_constant_expr (dim))
890 result = transformational_result (mask, dim, mask->ts.type,
891 mask->ts.kind, &mask->where);
892 init_result_expr (result, true, NULL);
894 return !dim || mask->rank == 1 ?
895 simplify_transformation_to_scalar (result, mask, NULL, gfc_and) :
896 simplify_transformation_to_array (result, mask, dim, NULL, gfc_and);
901 gfc_simplify_dint (gfc_expr *e)
903 gfc_expr *rtrunc, *result;
905 if (e->expr_type != EXPR_CONSTANT)
908 rtrunc = gfc_copy_expr (e);
909 mpfr_trunc (rtrunc->value.real, e->value.real);
911 result = gfc_real2real (rtrunc, gfc_default_double_kind);
913 gfc_free_expr (rtrunc);
915 return range_check (result, "DINT");
920 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
925 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
927 return &gfc_bad_expr;
929 if (e->expr_type != EXPR_CONSTANT)
932 result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
933 mpfr_round (result->value.real, e->value.real);
935 return range_check (result, "ANINT");
940 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
945 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
948 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
953 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
954 mpz_and (result->value.integer, x->value.integer, y->value.integer);
955 return range_check (result, "AND");
958 return gfc_get_logical_expr (kind, &x->where,
959 x->value.logical && y->value.logical);
968 gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
972 if (!is_constant_array_expr (mask)
973 || !gfc_is_constant_expr (dim))
976 result = transformational_result (mask, dim, mask->ts.type,
977 mask->ts.kind, &mask->where);
978 init_result_expr (result, false, NULL);
980 return !dim || mask->rank == 1 ?
981 simplify_transformation_to_scalar (result, mask, NULL, gfc_or) :
982 simplify_transformation_to_array (result, mask, dim, NULL, gfc_or);
987 gfc_simplify_dnint (gfc_expr *e)
991 if (e->expr_type != EXPR_CONSTANT)
994 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
995 mpfr_round (result->value.real, e->value.real);
997 return range_check (result, "DNINT");
1002 gfc_simplify_asin (gfc_expr *x)
1006 if (x->expr_type != EXPR_CONSTANT)
1012 if (mpfr_cmp_si (x->value.real, 1) > 0
1013 || mpfr_cmp_si (x->value.real, -1) < 0)
1015 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1017 return &gfc_bad_expr;
1019 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1020 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1024 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1025 mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1029 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1032 return range_check (result, "ASIN");
1037 gfc_simplify_asinh (gfc_expr *x)
1041 if (x->expr_type != EXPR_CONSTANT)
1044 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1049 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
1053 mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1057 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1060 return range_check (result, "ASINH");
1065 gfc_simplify_atan (gfc_expr *x)
1069 if (x->expr_type != EXPR_CONSTANT)
1072 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1077 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1081 mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1085 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1088 return range_check (result, "ATAN");
1093 gfc_simplify_atanh (gfc_expr *x)
1097 if (x->expr_type != EXPR_CONSTANT)
1103 if (mpfr_cmp_si (x->value.real, 1) >= 0
1104 || mpfr_cmp_si (x->value.real, -1) <= 0)
1106 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1108 return &gfc_bad_expr;
1110 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1111 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
1115 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1116 mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1120 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1123 return range_check (result, "ATANH");
1128 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
1132 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1135 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
1137 gfc_error ("If first argument of ATAN2 %L is zero, then the "
1138 "second argument must not be zero", &x->where);
1139 return &gfc_bad_expr;
1142 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1143 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
1145 return range_check (result, "ATAN2");
1150 gfc_simplify_bessel_j0 (gfc_expr *x)
1154 if (x->expr_type != EXPR_CONSTANT)
1157 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1158 mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
1160 return range_check (result, "BESSEL_J0");
1165 gfc_simplify_bessel_j1 (gfc_expr *x)
1169 if (x->expr_type != EXPR_CONSTANT)
1172 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1173 mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
1175 return range_check (result, "BESSEL_J1");
1180 gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
1185 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1188 n = mpz_get_si (order->value.integer);
1189 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1190 mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
1192 return range_check (result, "BESSEL_JN");
1197 gfc_simplify_bessel_y0 (gfc_expr *x)
1201 if (x->expr_type != EXPR_CONSTANT)
1204 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1205 mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
1207 return range_check (result, "BESSEL_Y0");
1212 gfc_simplify_bessel_y1 (gfc_expr *x)
1216 if (x->expr_type != EXPR_CONSTANT)
1219 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1220 mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
1222 return range_check (result, "BESSEL_Y1");
1227 gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
1232 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1235 n = mpz_get_si (order->value.integer);
1236 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1237 mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
1239 return range_check (result, "BESSEL_YN");
1244 gfc_simplify_bit_size (gfc_expr *e)
1246 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1247 return gfc_get_int_expr (e->ts.kind, &e->where,
1248 gfc_integer_kinds[i].bit_size);
1253 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
1257 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
1260 if (gfc_extract_int (bit, &b) != NULL || b < 0)
1261 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
1263 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
1264 mpz_tstbit (e->value.integer, b));
1269 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
1271 gfc_expr *ceil, *result;
1274 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
1276 return &gfc_bad_expr;
1278 if (e->expr_type != EXPR_CONSTANT)
1281 ceil = gfc_copy_expr (e);
1282 mpfr_ceil (ceil->value.real, e->value.real);
1284 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
1285 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
1287 gfc_free_expr (ceil);
1289 return range_check (result, "CEILING");
1294 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1296 return simplify_achar_char (e, k, "CHAR", false);
1300 /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1303 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1307 if (convert_boz (x, kind) == &gfc_bad_expr)
1308 return &gfc_bad_expr;
1310 if (convert_boz (y, kind) == &gfc_bad_expr)
1311 return &gfc_bad_expr;
1313 if (x->expr_type != EXPR_CONSTANT
1314 || (y != NULL && y->expr_type != EXPR_CONSTANT))
1317 result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
1322 mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
1326 mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
1330 mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1334 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1338 return range_check (result, name);
1343 mpfr_set_z (mpc_imagref (result->value.complex),
1344 y->value.integer, GFC_RND_MODE);
1348 mpfr_set (mpc_imagref (result->value.complex),
1349 y->value.real, GFC_RND_MODE);
1353 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1356 return range_check (result, name);
1361 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1365 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
1367 return &gfc_bad_expr;
1369 return simplify_cmplx ("CMPLX", x, y, kind);
1374 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
1378 if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
1379 kind = gfc_default_complex_kind;
1380 else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
1382 else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
1384 else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
1385 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
1389 return simplify_cmplx ("COMPLEX", x, y, kind);
1394 gfc_simplify_conjg (gfc_expr *e)
1398 if (e->expr_type != EXPR_CONSTANT)
1401 result = gfc_copy_expr (e);
1402 mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
1404 return range_check (result, "CONJG");
1409 gfc_simplify_cos (gfc_expr *x)
1413 if (x->expr_type != EXPR_CONSTANT)
1416 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1421 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1425 gfc_set_model_kind (x->ts.kind);
1426 mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1430 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1433 return range_check (result, "COS");
1438 gfc_simplify_cosh (gfc_expr *x)
1442 if (x->expr_type != EXPR_CONSTANT)
1445 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1450 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1454 mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1461 return range_check (result, "COSH");
1466 gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1470 if (!is_constant_array_expr (mask)
1471 || !gfc_is_constant_expr (dim)
1472 || !gfc_is_constant_expr (kind))
1475 result = transformational_result (mask, dim,
1477 get_kind (BT_INTEGER, kind, "COUNT",
1478 gfc_default_integer_kind),
1481 init_result_expr (result, 0, NULL);
1483 /* Passing MASK twice, once as data array, once as mask.
1484 Whenever gfc_count is called, '1' is added to the result. */
1485 return !dim || mask->rank == 1 ?
1486 simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
1487 simplify_transformation_to_array (result, mask, dim, mask, gfc_count);
1492 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
1494 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
1499 gfc_simplify_dble (gfc_expr *e)
1501 gfc_expr *result = NULL;
1503 if (e->expr_type != EXPR_CONSTANT)
1506 if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
1507 return &gfc_bad_expr;
1509 result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
1510 if (result == &gfc_bad_expr)
1511 return &gfc_bad_expr;
1513 return range_check (result, "DBLE");
1518 gfc_simplify_digits (gfc_expr *x)
1522 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1527 digits = gfc_integer_kinds[i].digits;
1532 digits = gfc_real_kinds[i].digits;
1539 return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
1544 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1549 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1552 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1553 result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
1558 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1559 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1561 mpz_set_ui (result->value.integer, 0);
1566 if (mpfr_cmp (x->value.real, y->value.real) > 0)
1567 mpfr_sub (result->value.real, x->value.real, y->value.real,
1570 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1575 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1578 return range_check (result, "DIM");
1583 gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1585 if (!is_constant_array_expr (vector_a)
1586 || !is_constant_array_expr (vector_b))
1589 gcc_assert (vector_a->rank == 1);
1590 gcc_assert (vector_b->rank == 1);
1591 gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
1593 return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0);
1598 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1600 gfc_expr *a1, *a2, *result;
1602 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1605 a1 = gfc_real2real (x, gfc_default_double_kind);
1606 a2 = gfc_real2real (y, gfc_default_double_kind);
1608 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
1609 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1614 return range_check (result, "DPROD");
1619 gfc_simplify_erf (gfc_expr *x)
1623 if (x->expr_type != EXPR_CONSTANT)
1626 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1627 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1629 return range_check (result, "ERF");
1634 gfc_simplify_erfc (gfc_expr *x)
1638 if (x->expr_type != EXPR_CONSTANT)
1641 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1642 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1644 return range_check (result, "ERFC");
1648 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
1650 #define MAX_ITER 200
1651 #define ARG_LIMIT 12
1653 /* Calculate ERFC_SCALED directly by its definition:
1655 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
1657 using a large precision for intermediate results. This is used for all
1658 but large values of the argument. */
1660 fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
1665 prec = mpfr_get_default_prec ();
1666 mpfr_set_default_prec (10 * prec);
1671 mpfr_set (a, arg, GFC_RND_MODE);
1672 mpfr_sqr (b, a, GFC_RND_MODE);
1673 mpfr_exp (b, b, GFC_RND_MODE);
1674 mpfr_erfc (a, a, GFC_RND_MODE);
1675 mpfr_mul (a, a, b, GFC_RND_MODE);
1677 mpfr_set (res, a, GFC_RND_MODE);
1678 mpfr_set_default_prec (prec);
1684 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
1686 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
1687 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
1690 This is used for large values of the argument. Intermediate calculations
1691 are performed with twice the precision. We don't do a fixed number of
1692 iterations of the sum, but stop when it has converged to the required
1695 asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
1697 mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
1702 prec = mpfr_get_default_prec ();
1703 mpfr_set_default_prec (2 * prec);
1713 mpfr_init (sumtrunc);
1714 mpfr_set_prec (oldsum, prec);
1715 mpfr_set_prec (sumtrunc, prec);
1717 mpfr_set (x, arg, GFC_RND_MODE);
1718 mpfr_set_ui (sum, 1, GFC_RND_MODE);
1719 mpz_set_ui (num, 1);
1721 mpfr_set (u, x, GFC_RND_MODE);
1722 mpfr_sqr (u, u, GFC_RND_MODE);
1723 mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
1724 mpfr_pow_si (u, u, -1, GFC_RND_MODE);
1726 for (i = 1; i < MAX_ITER; i++)
1728 mpfr_set (oldsum, sum, GFC_RND_MODE);
1730 mpz_mul_ui (num, num, 2 * i - 1);
1733 mpfr_set (w, u, GFC_RND_MODE);
1734 mpfr_pow_ui (w, w, i, GFC_RND_MODE);
1736 mpfr_set_z (v, num, GFC_RND_MODE);
1737 mpfr_mul (v, v, w, GFC_RND_MODE);
1739 mpfr_add (sum, sum, v, GFC_RND_MODE);
1741 mpfr_set (sumtrunc, sum, GFC_RND_MODE);
1742 if (mpfr_cmp (sumtrunc, oldsum) == 0)
1746 /* We should have converged by now; otherwise, ARG_LIMIT is probably
1748 gcc_assert (i < MAX_ITER);
1750 /* Divide by x * sqrt(Pi). */
1751 mpfr_const_pi (u, GFC_RND_MODE);
1752 mpfr_sqrt (u, u, GFC_RND_MODE);
1753 mpfr_mul (u, u, x, GFC_RND_MODE);
1754 mpfr_div (sum, sum, u, GFC_RND_MODE);
1756 mpfr_set (res, sum, GFC_RND_MODE);
1757 mpfr_set_default_prec (prec);
1759 mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
1765 gfc_simplify_erfc_scaled (gfc_expr *x)
1769 if (x->expr_type != EXPR_CONSTANT)
1772 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1773 if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
1774 asympt_erfc_scaled (result->value.real, x->value.real);
1776 fullprec_erfc_scaled (result->value.real, x->value.real);
1778 return range_check (result, "ERFC_SCALED");
1786 gfc_simplify_epsilon (gfc_expr *e)
1791 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1793 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
1794 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1796 return range_check (result, "EPSILON");
1801 gfc_simplify_exp (gfc_expr *x)
1805 if (x->expr_type != EXPR_CONSTANT)
1808 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1813 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1817 gfc_set_model_kind (x->ts.kind);
1818 mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1822 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1825 return range_check (result, "EXP");
1830 gfc_simplify_exponent (gfc_expr *x)
1835 if (x->expr_type != EXPR_CONSTANT)
1838 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1841 gfc_set_model (x->value.real);
1843 if (mpfr_sgn (x->value.real) == 0)
1845 mpz_set_ui (result->value.integer, 0);
1849 i = (int) mpfr_get_exp (x->value.real);
1850 mpz_set_si (result->value.integer, i);
1852 return range_check (result, "EXPONENT");
1857 gfc_simplify_float (gfc_expr *a)
1861 if (a->expr_type != EXPR_CONSTANT)
1866 if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
1867 return &gfc_bad_expr;
1869 result = gfc_copy_expr (a);
1872 result = gfc_int2real (a, gfc_default_real_kind);
1874 return range_check (result, "FLOAT");
1879 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1885 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1887 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1889 if (e->expr_type != EXPR_CONSTANT)
1892 gfc_set_model_kind (kind);
1895 mpfr_floor (floor, e->value.real);
1897 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
1898 gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
1902 return range_check (result, "FLOOR");
1907 gfc_simplify_fraction (gfc_expr *x)
1910 mpfr_t absv, exp, pow2;
1912 if (x->expr_type != EXPR_CONSTANT)
1915 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
1917 if (mpfr_sgn (x->value.real) == 0)
1919 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1923 gfc_set_model_kind (x->ts.kind);
1928 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1929 mpfr_log2 (exp, absv, GFC_RND_MODE);
1931 mpfr_trunc (exp, exp);
1932 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1934 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1936 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1938 mpfr_clears (exp, absv, pow2, NULL);
1940 return range_check (result, "FRACTION");
1945 gfc_simplify_gamma (gfc_expr *x)
1949 if (x->expr_type != EXPR_CONSTANT)
1952 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1953 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1955 return range_check (result, "GAMMA");
1960 gfc_simplify_huge (gfc_expr *e)
1965 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1966 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
1971 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1975 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1987 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
1991 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1994 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1995 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
1996 return range_check (result, "HYPOT");
2000 /* We use the processor's collating sequence, because all
2001 systems that gfortran currently works on are ASCII. */
2004 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
2010 if (e->expr_type != EXPR_CONSTANT)
2013 if (e->value.character.length != 1)
2015 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
2016 return &gfc_bad_expr;
2019 index = e->value.character.string[0];
2021 if (gfc_option.warn_surprising && index > 127)
2022 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
2025 k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
2027 return &gfc_bad_expr;
2029 result = gfc_get_int_expr (k, &e->where, index);
2031 return range_check (result, "IACHAR");
2036 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
2040 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2043 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2044 mpz_and (result->value.integer, x->value.integer, y->value.integer);
2046 return range_check (result, "IAND");
2051 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
2056 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2059 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2061 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
2062 return &gfc_bad_expr;
2065 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2067 if (pos >= gfc_integer_kinds[k].bit_size)
2069 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
2071 return &gfc_bad_expr;
2074 result = gfc_copy_expr (x);
2076 convert_mpz_to_unsigned (result->value.integer,
2077 gfc_integer_kinds[k].bit_size);
2079 mpz_clrbit (result->value.integer, pos);
2081 convert_mpz_to_signed (result->value.integer,
2082 gfc_integer_kinds[k].bit_size);
2089 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2096 if (x->expr_type != EXPR_CONSTANT
2097 || y->expr_type != EXPR_CONSTANT
2098 || z->expr_type != EXPR_CONSTANT)
2101 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2103 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
2104 return &gfc_bad_expr;
2107 if (gfc_extract_int (z, &len) != NULL || len < 0)
2109 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
2110 return &gfc_bad_expr;
2113 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
2115 bitsize = gfc_integer_kinds[k].bit_size;
2117 if (pos + len > bitsize)
2119 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2120 "bit size at %L", &y->where);
2121 return &gfc_bad_expr;
2124 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2125 convert_mpz_to_unsigned (result->value.integer,
2126 gfc_integer_kinds[k].bit_size);
2128 bits = XCNEWVEC (int, bitsize);
2130 for (i = 0; i < bitsize; i++)
2133 for (i = 0; i < len; i++)
2134 bits[i] = mpz_tstbit (x->value.integer, i + pos);
2136 for (i = 0; i < bitsize; i++)
2139 mpz_clrbit (result->value.integer, i);
2140 else if (bits[i] == 1)
2141 mpz_setbit (result->value.integer, i);
2143 gfc_internal_error ("IBITS: Bad bit");
2148 convert_mpz_to_signed (result->value.integer,
2149 gfc_integer_kinds[k].bit_size);
2156 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
2161 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2164 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
2166 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
2167 return &gfc_bad_expr;
2170 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2172 if (pos >= gfc_integer_kinds[k].bit_size)
2174 gfc_error ("Second argument of IBSET exceeds bit size at %L",
2176 return &gfc_bad_expr;
2179 result = gfc_copy_expr (x);
2181 convert_mpz_to_unsigned (result->value.integer,
2182 gfc_integer_kinds[k].bit_size);
2184 mpz_setbit (result->value.integer, pos);
2186 convert_mpz_to_signed (result->value.integer,
2187 gfc_integer_kinds[k].bit_size);
2194 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
2200 if (e->expr_type != EXPR_CONSTANT)
2203 if (e->value.character.length != 1)
2205 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
2206 return &gfc_bad_expr;
2209 index = e->value.character.string[0];
2211 k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
2213 return &gfc_bad_expr;
2215 result = gfc_get_int_expr (k, &e->where, index);
2217 return range_check (result, "ICHAR");
2222 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
2226 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2229 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2230 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
2232 return range_check (result, "IEOR");
2237 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
2240 int back, len, lensub;
2241 int i, j, k, count, index = 0, start;
2243 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
2244 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
2247 if (b != NULL && b->value.logical != 0)
2252 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
2254 return &gfc_bad_expr;
2256 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
2258 len = x->value.character.length;
2259 lensub = y->value.character.length;
2263 mpz_set_si (result->value.integer, 0);
2271 mpz_set_si (result->value.integer, 1);
2274 else if (lensub == 1)
2276 for (i = 0; i < len; i++)
2278 for (j = 0; j < lensub; j++)
2280 if (y->value.character.string[j]
2281 == x->value.character.string[i])
2291 for (i = 0; i < len; i++)
2293 for (j = 0; j < lensub; j++)
2295 if (y->value.character.string[j]
2296 == x->value.character.string[i])
2301 for (k = 0; k < lensub; k++)
2303 if (y->value.character.string[k]
2304 == x->value.character.string[k + start])
2308 if (count == lensub)
2323 mpz_set_si (result->value.integer, len + 1);
2326 else if (lensub == 1)
2328 for (i = 0; i < len; i++)
2330 for (j = 0; j < lensub; j++)
2332 if (y->value.character.string[j]
2333 == x->value.character.string[len - i])
2335 index = len - i + 1;
2343 for (i = 0; i < len; i++)
2345 for (j = 0; j < lensub; j++)
2347 if (y->value.character.string[j]
2348 == x->value.character.string[len - i])
2351 if (start <= len - lensub)
2354 for (k = 0; k < lensub; k++)
2355 if (y->value.character.string[k]
2356 == x->value.character.string[k + start])
2359 if (count == lensub)
2376 mpz_set_si (result->value.integer, index);
2377 return range_check (result, "INDEX");
2382 simplify_intconv (gfc_expr *e, int kind, const char *name)
2384 gfc_expr *result = NULL;
2386 if (e->expr_type != EXPR_CONSTANT)
2389 result = gfc_convert_constant (e, BT_INTEGER, kind);
2390 if (result == &gfc_bad_expr)
2391 return &gfc_bad_expr;
2393 return range_check (result, name);
2398 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
2402 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
2404 return &gfc_bad_expr;
2406 return simplify_intconv (e, kind, "INT");
2410 gfc_simplify_int2 (gfc_expr *e)
2412 return simplify_intconv (e, 2, "INT2");
2417 gfc_simplify_int8 (gfc_expr *e)
2419 return simplify_intconv (e, 8, "INT8");
2424 gfc_simplify_long (gfc_expr *e)
2426 return simplify_intconv (e, 4, "LONG");
2431 gfc_simplify_ifix (gfc_expr *e)
2433 gfc_expr *rtrunc, *result;
2435 if (e->expr_type != EXPR_CONSTANT)
2438 rtrunc = gfc_copy_expr (e);
2439 mpfr_trunc (rtrunc->value.real, e->value.real);
2441 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2443 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2445 gfc_free_expr (rtrunc);
2447 return range_check (result, "IFIX");
2452 gfc_simplify_idint (gfc_expr *e)
2454 gfc_expr *rtrunc, *result;
2456 if (e->expr_type != EXPR_CONSTANT)
2459 rtrunc = gfc_copy_expr (e);
2460 mpfr_trunc (rtrunc->value.real, e->value.real);
2462 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2464 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
2466 gfc_free_expr (rtrunc);
2468 return range_check (result, "IDINT");
2473 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
2477 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2480 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2481 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2483 return range_check (result, "IOR");
2488 gfc_simplify_is_iostat_end (gfc_expr *x)
2490 if (x->expr_type != EXPR_CONSTANT)
2493 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2494 mpz_cmp_si (x->value.integer,
2495 LIBERROR_END) == 0);
2500 gfc_simplify_is_iostat_eor (gfc_expr *x)
2502 if (x->expr_type != EXPR_CONSTANT)
2505 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2506 mpz_cmp_si (x->value.integer,
2507 LIBERROR_EOR) == 0);
2512 gfc_simplify_isnan (gfc_expr *x)
2514 if (x->expr_type != EXPR_CONSTANT)
2517 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2518 mpfr_nan_p (x->value.real));
2523 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
2526 int shift, ashift, isize, k, *bits, i;
2528 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2531 if (gfc_extract_int (s, &shift) != NULL)
2533 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
2534 return &gfc_bad_expr;
2537 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2539 isize = gfc_integer_kinds[k].bit_size;
2548 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
2549 "at %L", &s->where);
2550 return &gfc_bad_expr;
2553 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
2557 mpz_set (result->value.integer, e->value.integer);
2558 return range_check (result, "ISHFT");
2561 bits = XCNEWVEC (int, isize);
2563 for (i = 0; i < isize; i++)
2564 bits[i] = mpz_tstbit (e->value.integer, i);
2568 for (i = 0; i < shift; i++)
2569 mpz_clrbit (result->value.integer, i);
2571 for (i = 0; i < isize - shift; i++)
2574 mpz_clrbit (result->value.integer, i + shift);
2576 mpz_setbit (result->value.integer, i + shift);
2581 for (i = isize - 1; i >= isize - ashift; i--)
2582 mpz_clrbit (result->value.integer, i);
2584 for (i = isize - 1; i >= ashift; i--)
2587 mpz_clrbit (result->value.integer, i - ashift);
2589 mpz_setbit (result->value.integer, i - ashift);
2593 convert_mpz_to_signed (result->value.integer, isize);
2601 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
2604 int shift, ashift, isize, ssize, delta, k;
2607 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2610 if (gfc_extract_int (s, &shift) != NULL)
2612 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
2613 return &gfc_bad_expr;
2616 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2617 isize = gfc_integer_kinds[k].bit_size;
2621 if (sz->expr_type != EXPR_CONSTANT)
2624 if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
2626 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
2627 return &gfc_bad_expr;
2632 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
2633 "BIT_SIZE of first argument at %L", &s->where);
2634 return &gfc_bad_expr;
2648 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2649 "third argument at %L", &s->where);
2651 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2652 "BIT_SIZE of first argument at %L", &s->where);
2653 return &gfc_bad_expr;
2656 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
2658 mpz_set (result->value.integer, e->value.integer);
2663 convert_mpz_to_unsigned (result->value.integer, isize);
2665 bits = XCNEWVEC (int, ssize);
2667 for (i = 0; i < ssize; i++)
2668 bits[i] = mpz_tstbit (e->value.integer, i);
2670 delta = ssize - ashift;
2674 for (i = 0; i < delta; i++)
2677 mpz_clrbit (result->value.integer, i + shift);
2679 mpz_setbit (result->value.integer, i + shift);
2682 for (i = delta; i < ssize; i++)
2685 mpz_clrbit (result->value.integer, i - delta);
2687 mpz_setbit (result->value.integer, i - delta);
2692 for (i = 0; i < ashift; i++)
2695 mpz_clrbit (result->value.integer, i + delta);
2697 mpz_setbit (result->value.integer, i + delta);
2700 for (i = ashift; i < ssize; i++)
2703 mpz_clrbit (result->value.integer, i + shift);
2705 mpz_setbit (result->value.integer, i + shift);
2709 convert_mpz_to_signed (result->value.integer, isize);
2717 gfc_simplify_kind (gfc_expr *e)
2719 return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
2724 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2725 gfc_array_spec *as, gfc_ref *ref, bool coarray)
2727 gfc_expr *l, *u, *result;
2730 /* The last dimension of an assumed-size array is special. */
2731 if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2732 || (coarray && d == as->rank + as->corank))
2734 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2735 return gfc_copy_expr (as->lower[d-1]);
2740 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2741 gfc_default_integer_kind);
2743 return &gfc_bad_expr;
2745 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
2748 /* Then, we need to know the extent of the given dimension. */
2749 if (coarray || ref->u.ar.type == AR_FULL)
2754 if (l->expr_type != EXPR_CONSTANT || u == NULL
2755 || u->expr_type != EXPR_CONSTANT)
2758 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2762 mpz_set_si (result->value.integer, 0);
2764 mpz_set_si (result->value.integer, 1);
2768 /* Nonzero extent. */
2770 mpz_set (result->value.integer, u->value.integer);
2772 mpz_set (result->value.integer, l->value.integer);
2779 if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer)
2784 mpz_set_si (result->value.integer, (long int) 1);
2787 return range_check (result, upper ? "UBOUND" : "LBOUND");
2792 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2798 if (array->expr_type != EXPR_VARIABLE)
2801 /* Follow any component references. */
2802 as = array->symtree->n.sym->as;
2803 for (ref = array->ref; ref; ref = ref->next)
2808 switch (ref->u.ar.type)
2815 /* We're done because 'as' has already been set in the
2816 previous iteration. */
2833 as = ref->u.c.component->as;
2845 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2850 /* Multi-dimensional bounds. */
2851 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2855 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2856 if (upper && as->type == AS_ASSUMED_SIZE)
2858 /* An error message will be emitted in
2859 check_assumed_size_reference (resolve.c). */
2860 return &gfc_bad_expr;
2863 /* Simplify the bounds for each dimension. */
2864 for (d = 0; d < array->rank; d++)
2866 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
2868 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2872 for (j = 0; j < d; j++)
2873 gfc_free_expr (bounds[j]);
2878 /* Allocate the result expression. */
2879 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2880 gfc_default_integer_kind);
2882 return &gfc_bad_expr;
2884 e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
2886 /* The result is a rank 1 array; its size is the rank of the first
2887 argument to {L,U}BOUND. */
2889 e->shape = gfc_get_shape (1);
2890 mpz_init_set_ui (e->shape[0], array->rank);
2892 /* Create the constructor for this array. */
2893 for (d = 0; d < array->rank; d++)
2894 gfc_constructor_append_expr (&e->value.constructor,
2895 bounds[d], &e->where);
2901 /* A DIM argument is specified. */
2902 if (dim->expr_type != EXPR_CONSTANT)
2905 d = mpz_get_si (dim->value.integer);
2907 if (d < 1 || d > as->rank
2908 || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2910 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2911 return &gfc_bad_expr;
2914 return simplify_bound_dim (array, kind, d, upper, as, ref, false);
2920 simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2926 if (array->expr_type != EXPR_VARIABLE)
2929 /* Follow any component references. */
2930 as = array->symtree->n.sym->as;
2931 for (ref = array->ref; ref; ref = ref->next)
2936 switch (ref->u.ar.type)
2939 if (ref->next == NULL)
2941 gcc_assert (ref->u.ar.as->corank > 0
2942 && ref->u.ar.as->rank == 0);
2950 /* We're done because 'as' has already been set in the
2951 previous iteration. */
2968 as = ref->u.c.component->as;
2980 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2985 /* Multi-dimensional cobounds. */
2986 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2990 /* Simplify the cobounds for each dimension. */
2991 for (d = 0; d < as->corank; d++)
2993 bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
2994 upper, as, ref, true);
2995 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2999 for (j = 0; j < d; j++)
3000 gfc_free_expr (bounds[j]);
3005 /* Allocate the result expression. */
3006 e = gfc_get_expr ();
3007 e->where = array->where;
3008 e->expr_type = EXPR_ARRAY;
3009 e->ts.type = BT_INTEGER;
3010 k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
3011 gfc_default_integer_kind);
3015 return &gfc_bad_expr;
3019 /* The result is a rank 1 array; its size is the rank of the first
3020 argument to {L,U}COBOUND. */
3022 e->shape = gfc_get_shape (1);
3023 mpz_init_set_ui (e->shape[0], as->corank);
3025 /* Create the constructor for this array. */
3026 for (d = 0; d < as->corank; d++)
3027 gfc_constructor_append_expr (&e->value.constructor,
3028 bounds[d], &e->where);
3033 /* A DIM argument is specified. */
3034 if (dim->expr_type != EXPR_CONSTANT)
3037 d = mpz_get_si (dim->value.integer);
3039 if (d < 1 || d > as->corank)
3041 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3042 return &gfc_bad_expr;
3045 return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
3051 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3053 return simplify_bound (array, dim, kind, 0);
3058 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3061 /* return simplify_cobound (array, dim, kind, 0);*/
3063 e = simplify_cobound (array, dim, kind, 0);
3067 gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
3068 "cobounds at %L", &array->where);
3069 return &gfc_bad_expr;
3073 gfc_simplify_leadz (gfc_expr *e)
3075 unsigned long lz, bs;
3078 if (e->expr_type != EXPR_CONSTANT)
3081 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3082 bs = gfc_integer_kinds[i].bit_size;
3083 if (mpz_cmp_si (e->value.integer, 0) == 0)
3085 else if (mpz_cmp_si (e->value.integer, 0) < 0)
3088 lz = bs - mpz_sizeinbase (e->value.integer, 2);
3090 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
3095 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
3098 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
3101 return &gfc_bad_expr;
3103 if (e->expr_type == EXPR_CONSTANT)
3105 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3106 mpz_set_si (result->value.integer, e->value.character.length);
3107 return range_check (result, "LEN");
3109 else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3110 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3111 && e->ts.u.cl->length->ts.type == BT_INTEGER)
3113 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3114 mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
3115 return range_check (result, "LEN");
3123 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
3127 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3130 return &gfc_bad_expr;
3132 if (e->expr_type != EXPR_CONSTANT)
3135 len = e->value.character.length;
3136 for (count = 0, i = 1; i <= len; i++)
3137 if (e->value.character.string[len - i] == ' ')
3142 result = gfc_get_int_expr (k, &e->where, len - count);
3143 return range_check (result, "LEN_TRIM");
3147 gfc_simplify_lgamma (gfc_expr *x)
3152 if (x->expr_type != EXPR_CONSTANT)
3155 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3156 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
3158 return range_check (result, "LGAMMA");
3163 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
3165 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3168 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3169 gfc_compare_string (a, b) >= 0);
3174 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
3176 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3179 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3180 gfc_compare_string (a, b) > 0);
3185 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
3187 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3190 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3191 gfc_compare_string (a, b) <= 0);
3196 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
3198 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3201 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3202 gfc_compare_string (a, b) < 0);
3207 gfc_simplify_log (gfc_expr *x)
3211 if (x->expr_type != EXPR_CONSTANT)
3214 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3219 if (mpfr_sgn (x->value.real) <= 0)
3221 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3222 "to zero", &x->where);
3223 gfc_free_expr (result);
3224 return &gfc_bad_expr;
3227 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
3231 if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3232 && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
3234 gfc_error ("Complex argument of LOG at %L cannot be zero",
3236 gfc_free_expr (result);
3237 return &gfc_bad_expr;
3240 gfc_set_model_kind (x->ts.kind);
3241 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3245 gfc_internal_error ("gfc_simplify_log: bad type");
3248 return range_check (result, "LOG");
3253 gfc_simplify_log10 (gfc_expr *x)
3257 if (x->expr_type != EXPR_CONSTANT)
3260 if (mpfr_sgn (x->value.real) <= 0)
3262 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3263 "to zero", &x->where);
3264 return &gfc_bad_expr;
3267 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3268 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
3270 return range_check (result, "LOG10");
3275 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
3279 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
3281 return &gfc_bad_expr;
3283 if (e->expr_type != EXPR_CONSTANT)
3286 return gfc_get_logical_expr (kind, &e->where, e->value.logical);
3291 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3294 int row, result_rows, col, result_columns;
3295 int stride_a, offset_a, stride_b, offset_b;
3297 if (!is_constant_array_expr (matrix_a)
3298 || !is_constant_array_expr (matrix_b))
3301 gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
3302 result = gfc_get_array_expr (matrix_a->ts.type,
3306 if (matrix_a->rank == 1 && matrix_b->rank == 2)
3309 result_columns = mpz_get_si (matrix_b->shape[0]);
3311 stride_b = mpz_get_si (matrix_b->shape[0]);
3314 result->shape = gfc_get_shape (result->rank);
3315 mpz_init_set_si (result->shape[0], result_columns);
3317 else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3319 result_rows = mpz_get_si (matrix_b->shape[0]);
3321 stride_a = mpz_get_si (matrix_a->shape[0]);
3325 result->shape = gfc_get_shape (result->rank);
3326 mpz_init_set_si (result->shape[0], result_rows);
3328 else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3330 result_rows = mpz_get_si (matrix_a->shape[0]);
3331 result_columns = mpz_get_si (matrix_b->shape[1]);
3332 stride_a = mpz_get_si (matrix_a->shape[1]);
3333 stride_b = mpz_get_si (matrix_b->shape[0]);
3336 result->shape = gfc_get_shape (result->rank);
3337 mpz_init_set_si (result->shape[0], result_rows);
3338 mpz_init_set_si (result->shape[1], result_columns);
3343 offset_a = offset_b = 0;
3344 for (col = 0; col < result_columns; ++col)
3348 for (row = 0; row < result_rows; ++row)
3350 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
3351 matrix_b, 1, offset_b);
3352 gfc_constructor_append_expr (&result->value.constructor,
3358 offset_b += stride_b;
3366 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3368 if (tsource->expr_type != EXPR_CONSTANT
3369 || fsource->expr_type != EXPR_CONSTANT
3370 || mask->expr_type != EXPR_CONSTANT)
3373 return gfc_copy_expr (mask->value.logical ? tsource : fsource);
3377 /* Selects bewteen current value and extremum for simplify_min_max
3378 and simplify_minval_maxval. */
3380 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
3382 switch (arg->ts.type)
3385 if (mpz_cmp (arg->value.integer,
3386 extremum->value.integer) * sign > 0)
3387 mpz_set (extremum->value.integer, arg->value.integer);
3391 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
3393 mpfr_max (extremum->value.real, extremum->value.real,
3394 arg->value.real, GFC_RND_MODE);
3396 mpfr_min (extremum->value.real, extremum->value.real,
3397 arg->value.real, GFC_RND_MODE);
3401 #define LENGTH(x) ((x)->value.character.length)
3402 #define STRING(x) ((x)->value.character.string)
3403 if (LENGTH(extremum) < LENGTH(arg))
3405 gfc_char_t *tmp = STRING(extremum);
3407 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
3408 memcpy (STRING(extremum), tmp,
3409 LENGTH(extremum) * sizeof (gfc_char_t));
3410 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
3411 LENGTH(arg) - LENGTH(extremum));
3412 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
3413 LENGTH(extremum) = LENGTH(arg);
3417 if (gfc_compare_string (arg, extremum) * sign > 0)
3419 gfc_free (STRING(extremum));
3420 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
3421 memcpy (STRING(extremum), STRING(arg),
3422 LENGTH(arg) * sizeof (gfc_char_t));
3423 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
3424 LENGTH(extremum) - LENGTH(arg));
3425 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
3432 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
3437 /* This function is special since MAX() can take any number of
3438 arguments. The simplified expression is a rewritten version of the
3439 argument list containing at most one constant element. Other
3440 constant elements are deleted. Because the argument list has
3441 already been checked, this function always succeeds. sign is 1 for
3442 MAX(), -1 for MIN(). */
3445 simplify_min_max (gfc_expr *expr, int sign)
3447 gfc_actual_arglist *arg, *last, *extremum;
3448 gfc_intrinsic_sym * specific;
3452 specific = expr->value.function.isym;
3454 arg = expr->value.function.actual;
3456 for (; arg; last = arg, arg = arg->next)
3458 if (arg->expr->expr_type != EXPR_CONSTANT)
3461 if (extremum == NULL)
3467 min_max_choose (arg->expr, extremum->expr, sign);
3469 /* Delete the extra constant argument. */
3471 expr->value.function.actual = arg->next;
3473 last->next = arg->next;
3476 gfc_free_actual_arglist (arg);
3480 /* If there is one value left, replace the function call with the
3482 if (expr->value.function.actual->next != NULL)
3485 /* Convert to the correct type and kind. */
3486 if (expr->ts.type != BT_UNKNOWN)
3487 return gfc_convert_constant (expr->value.function.actual->expr,
3488 expr->ts.type, expr->ts.kind);
3490 if (specific->ts.type != BT_UNKNOWN)
3491 return gfc_convert_constant (expr->value.function.actual->expr,
3492 specific->ts.type, specific->ts.kind);
3494 return gfc_copy_expr (expr->value.function.actual->expr);
3499 gfc_simplify_min (gfc_expr *e)
3501 return simplify_min_max (e, -1);
3506 gfc_simplify_max (gfc_expr *e)
3508 return simplify_min_max (e, 1);
3512 /* This is a simplified version of simplify_min_max to provide
3513 simplification of minval and maxval for a vector. */
3516 simplify_minval_maxval (gfc_expr *expr, int sign)
3518 gfc_constructor *c, *extremum;
3519 gfc_intrinsic_sym * specific;
3522 specific = expr->value.function.isym;
3524 for (c = gfc_constructor_first (expr->value.constructor);
3525 c; c = gfc_constructor_next (c))
3527 if (c->expr->expr_type != EXPR_CONSTANT)
3530 if (extremum == NULL)
3536 min_max_choose (c->expr, extremum->expr, sign);
3539 if (extremum == NULL)
3542 /* Convert to the correct type and kind. */
3543 if (expr->ts.type != BT_UNKNOWN)
3544 return gfc_convert_constant (extremum->expr,
3545 expr->ts.type, expr->ts.kind);
3547 if (specific->ts.type != BT_UNKNOWN)
3548 return gfc_convert_constant (extremum->expr,
3549 specific->ts.type, specific->ts.kind);
3551 return gfc_copy_expr (extremum->expr);
3556 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3558 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3561 return simplify_minval_maxval (array, -1);
3566 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3568 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3571 return simplify_minval_maxval (array, 1);
3576 gfc_simplify_maxexponent (gfc_expr *x)
3578 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3579 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3580 gfc_real_kinds[i].max_exponent);
3585 gfc_simplify_minexponent (gfc_expr *x)
3587 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3588 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3589 gfc_real_kinds[i].min_exponent);
3594 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
3600 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3603 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3604 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3609 if (mpz_cmp_ui (p->value.integer, 0) == 0)
3611 /* Result is processor-dependent. */
3612 gfc_error ("Second argument MOD at %L is zero", &a->where);
3613 gfc_free_expr (result);
3614 return &gfc_bad_expr;
3616 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
3620 if (mpfr_cmp_ui (p->value.real, 0) == 0)
3622 /* Result is processor-dependent. */
3623 gfc_error ("Second argument of MOD at %L is zero", &p->where);
3624 gfc_free_expr (result);
3625 return &gfc_bad_expr;
3628 gfc_set_model_kind (kind);
3630 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3631 mpfr_trunc (tmp, tmp);
3632 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3633 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3638 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
3641 return range_check (result, "MOD");
3646 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
3652 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3655 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3656 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3661 if (mpz_cmp_ui (p->value.integer, 0) == 0)
3663 /* Result is processor-dependent. This processor just opts
3664 to not handle it at all. */
3665 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
3666 gfc_free_expr (result);
3667 return &gfc_bad_expr;
3669 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
3674 if (mpfr_cmp_ui (p->value.real, 0) == 0)
3676 /* Result is processor-dependent. */
3677 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
3678 gfc_free_expr (result);
3679 return &gfc_bad_expr;
3682 gfc_set_model_kind (kind);
3684 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3685 mpfr_floor (tmp, tmp);
3686 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3687 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3692 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
3695 return range_check (result, "MODULO");
3699 /* Exists for the sole purpose of consistency with other intrinsics. */
3701 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
3702 gfc_expr *fp ATTRIBUTE_UNUSED,
3703 gfc_expr *l ATTRIBUTE_UNUSED,
3704 gfc_expr *to ATTRIBUTE_UNUSED,
3705 gfc_expr *tp ATTRIBUTE_UNUSED)
3712 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
3715 mp_exp_t emin, emax;
3718 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3721 if (mpfr_sgn (s->value.real) == 0)
3723 gfc_error ("Second argument of NEAREST at %L shall not be zero",
3725 return &gfc_bad_expr;
3728 result = gfc_copy_expr (x);
3730 /* Save current values of emin and emax. */
3731 emin = mpfr_get_emin ();
3732 emax = mpfr_get_emax ();
3734 /* Set emin and emax for the current model number. */
3735 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
3736 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
3737 mpfr_get_prec(result->value.real) + 1);
3738 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
3739 mpfr_check_range (result->value.real, 0, GMP_RNDU);
3741 if (mpfr_sgn (s->value.real) > 0)
3743 mpfr_nextabove (result->value.real);
3744 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
3748 mpfr_nextbelow (result->value.real);
3749 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
3752 mpfr_set_emin (emin);
3753 mpfr_set_emax (emax);
3755 /* Only NaN can occur. Do not use range check as it gives an
3756 error for denormal numbers. */
3757 if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
3759 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
3760 gfc_free_expr (result);
3761 return &gfc_bad_expr;
3769 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
3771 gfc_expr *itrunc, *result;
3774 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
3776 return &gfc_bad_expr;
3778 if (e->expr_type != EXPR_CONSTANT)
3781 itrunc = gfc_copy_expr (e);
3782 mpfr_round (itrunc->value.real, e->value.real);
3784 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
3785 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
3787 gfc_free_expr (itrunc);
3789 return range_check (result, name);
3794 gfc_simplify_new_line (gfc_expr *e)
3798 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
3799 result->value.character.string[0] = '\n';
3806 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
3808 return simplify_nint ("NINT", e, k);
3813 gfc_simplify_idnint (gfc_expr *e)
3815 return simplify_nint ("IDNINT", e, NULL);
3820 gfc_simplify_not (gfc_expr *e)
3824 if (e->expr_type != EXPR_CONSTANT)
3827 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3828 mpz_com (result->value.integer, e->value.integer);
3830 return range_check (result, "NOT");
3835 gfc_simplify_null (gfc_expr *mold)
3841 result = gfc_copy_expr (mold);
3842 result->expr_type = EXPR_NULL;
3845 result = gfc_get_null_expr (NULL);
3852 gfc_simplify_num_images (void)
3856 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3858 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3859 return &gfc_bad_expr;
3862 /* FIXME: gfc_current_locus is wrong. */
3863 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3864 &gfc_current_locus);
3865 mpz_set_si (result->value.integer, 1);
3871 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3876 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3879 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3884 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
3885 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3886 return range_check (result, "OR");
3889 return gfc_get_logical_expr (kind, &x->where,
3890 x->value.logical || y->value.logical);
3898 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
3901 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
3903 if (!is_constant_array_expr(array)
3904 || !is_constant_array_expr(vector)
3905 || (!gfc_is_constant_expr (mask)
3906 && !is_constant_array_expr(mask)))
3909 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
3911 array_ctor = gfc_constructor_first (array->value.constructor);
3912 vector_ctor = vector
3913 ? gfc_constructor_first (vector->value.constructor)
3916 if (mask->expr_type == EXPR_CONSTANT
3917 && mask->value.logical)
3919 /* Copy all elements of ARRAY to RESULT. */
3922 gfc_constructor_append_expr (&result->value.constructor,
3923 gfc_copy_expr (array_ctor->expr),
3926 array_ctor = gfc_constructor_next (array_ctor);
3927 vector_ctor = gfc_constructor_next (vector_ctor);
3930 else if (mask->expr_type == EXPR_ARRAY)
3932 /* Copy only those elements of ARRAY to RESULT whose
3933 MASK equals .TRUE.. */
3934 mask_ctor = gfc_constructor_first (mask->value.constructor);
3937 if (mask_ctor->expr->value.logical)
3939 gfc_constructor_append_expr (&result->value.constructor,
3940 gfc_copy_expr (array_ctor->expr),
3942 vector_ctor = gfc_constructor_next (vector_ctor);
3945 array_ctor = gfc_constructor_next (array_ctor);
3946 mask_ctor = gfc_constructor_next (mask_ctor);
3950 /* Append any left-over elements from VECTOR to RESULT. */
3953 gfc_constructor_append_expr (&result->value.constructor,
3954 gfc_copy_expr (vector_ctor->expr),
3956 vector_ctor = gfc_constructor_next (vector_ctor);
3959 result->shape = gfc_get_shape (1);
3960 gfc_array_size (result, &result->shape[0]);
3962 if (array->ts.type == BT_CHARACTER)
3963 result->ts.u.cl = array->ts.u.cl;
3970 gfc_simplify_precision (gfc_expr *e)
3972 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3973 return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3974 gfc_real_kinds[i].precision);
3979 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3983 if (!is_constant_array_expr (array)
3984 || !gfc_is_constant_expr (dim))
3988 && !is_constant_array_expr (mask)
3989 && mask->expr_type != EXPR_CONSTANT)
3992 result = transformational_result (array, dim, array->ts.type,
3993 array->ts.kind, &array->where);
3994 init_result_expr (result, 1, NULL);
3996 return !dim || array->rank == 1 ?
3997 simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
3998 simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
4003 gfc_simplify_radix (gfc_expr *e)
4006 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4011 i = gfc_integer_kinds[i].radix;
4015 i = gfc_real_kinds[i].radix;
4022 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4027 gfc_simplify_range (gfc_expr *e)
4030 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4035 i = gfc_integer_kinds[i].range;
4040 i = gfc_real_kinds[i].range;
4047 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4052 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
4054 gfc_expr *result = NULL;
4057 if (e->ts.type == BT_COMPLEX)
4058 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4060 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
4063 return &gfc_bad_expr;
4065 if (e->expr_type != EXPR_CONSTANT)
4068 if (convert_boz (e, kind) == &gfc_bad_expr)
4069 return &gfc_bad_expr;
4071 result = gfc_convert_constant (e, BT_REAL, kind);
4072 if (result == &gfc_bad_expr)
4073 return &gfc_bad_expr;
4075 return range_check (result, "REAL");
4080 gfc_simplify_realpart (gfc_expr *e)
4084 if (e->expr_type != EXPR_CONSTANT)
4087 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
4088 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
4090 return range_check (result, "REALPART");
4094 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
4097 int i, j, len, ncop, nlen;
4099 bool have_length = false;
4101 /* If NCOPIES isn't a constant, there's nothing we can do. */
4102 if (n->expr_type != EXPR_CONSTANT)
4105 /* If NCOPIES is negative, it's an error. */
4106 if (mpz_sgn (n->value.integer) < 0)
4108 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4110 return &gfc_bad_expr;
4113 /* If we don't know the character length, we can do no more. */
4114 if (e->ts.u.cl && e->ts.u.cl->length
4115 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4117 len = mpz_get_si (e->ts.u.cl->length->value.integer);
4120 else if (e->expr_type == EXPR_CONSTANT
4121 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
4123 len = e->value.character.length;
4128 /* If the source length is 0, any value of NCOPIES is valid
4129 and everything behaves as if NCOPIES == 0. */
4132 mpz_set_ui (ncopies, 0);
4134 mpz_set (ncopies, n->value.integer);
4136 /* Check that NCOPIES isn't too large. */
4142 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
4144 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4148 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4149 e->ts.u.cl->length->value.integer);
4153 mpz_init_set_si (mlen, len);
4154 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4158 /* The check itself. */
4159 if (mpz_cmp (ncopies, max) > 0)
4162 mpz_clear (ncopies);
4163 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4165 return &gfc_bad_expr;
4170 mpz_clear (ncopies);
4172 /* For further simplification, we need the character string to be
4174 if (e->expr_type != EXPR_CONSTANT)
4178 (e->ts.u.cl->length &&
4179 mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
4181 const char *res = gfc_extract_int (n, &ncop);
4182 gcc_assert (res == NULL);
4187 len = e->value.character.length;
4190 result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
4193 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
4195 len = e->value.character.length;
4198 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
4199 for (i = 0; i < ncop; i++)
4200 for (j = 0; j < len; j++)
4201 result->value.character.string[j+i*len]= e->value.character.string[j];
4203 result->value.character.string[nlen] = '\0'; /* For debugger */
4208 /* This one is a bear, but mainly has to do with shuffling elements. */
4211 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4212 gfc_expr *pad, gfc_expr *order_exp)
4214 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4215 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
4219 gfc_expr *e, *result;
4221 /* Check that argument expression types are OK. */
4222 if (!is_constant_array_expr (source)
4223 || !is_constant_array_expr (shape_exp)
4224 || !is_constant_array_expr (pad)
4225 || !is_constant_array_expr (order_exp))
4228 /* Proceed with simplification, unpacking the array. */
4235 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
4239 gfc_extract_int (e, &shape[rank]);
4241 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
4242 gcc_assert (shape[rank] >= 0);
4247 gcc_assert (rank > 0);
4249 /* Now unpack the order array if present. */
4250 if (order_exp == NULL)
4252 for (i = 0; i < rank; i++)
4257 for (i = 0; i < rank; i++)
4260 for (i = 0; i < rank; i++)
4262 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
4265 gfc_extract_int (e, &order[i]);
4267 gcc_assert (order[i] >= 1 && order[i] <= rank);
4269 gcc_assert (x[order[i]] == 0);
4274 /* Count the elements in the source and padding arrays. */
4279 gfc_array_size (pad, &size);
4280 npad = mpz_get_ui (size);
4284 gfc_array_size (source, &size);
4285 nsource = mpz_get_ui (size);
4288 /* If it weren't for that pesky permutation we could just loop
4289 through the source and round out any shortage with pad elements.
4290 But no, someone just had to have the compiler do something the
4291 user should be doing. */
4293 for (i = 0; i < rank; i++)
4296 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4298 result->rank = rank;
4299 result->shape = gfc_get_shape (rank);
4300 for (i = 0; i < rank; i++)
4301 mpz_init_set_ui (result->shape[i], shape[i]);
4303 while (nsource > 0 || npad > 0)
4305 /* Figure out which element to extract. */
4306 mpz_set_ui (index, 0);
4308 for (i = rank - 1; i >= 0; i--)
4310 mpz_add_ui (index, index, x[order[i]]);
4312 mpz_mul_ui (index, index, shape[order[i - 1]]);
4315 if (mpz_cmp_ui (index, INT_MAX) > 0)
4316 gfc_internal_error ("Reshaped array too large at %C");
4318 j = mpz_get_ui (index);
4321 e = gfc_constructor_lookup_expr (source->value.constructor, j);
4324 gcc_assert (npad > 0);
4328 e = gfc_constructor_lookup_expr (pad->value.constructor, j);
4332 gfc_constructor_append_expr (&result->value.constructor,
4333 gfc_copy_expr (e), &e->where);
4335 /* Calculate the next element. */
4339 if (++x[i] < shape[i])
4355 gfc_simplify_rrspacing (gfc_expr *x)
4361 if (x->expr_type != EXPR_CONSTANT)
4364 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4366 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4367 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4369 /* Special case x = -0 and 0. */
4370 if (mpfr_sgn (result->value.real) == 0)
4372 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4376 /* | x * 2**(-e) | * 2**p. */
4377 e = - (long int) mpfr_get_exp (x->value.real);
4378 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
4380 p = (long int) gfc_real_kinds[i].digits;
4381 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
4383 return range_check (result, "RRSPACING");
4388 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
4390 int k, neg_flag, power, exp_range;
4391 mpfr_t scale, radix;
4394 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4397 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4399 if (mpfr_sgn (x->value.real) == 0)
4401 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4405 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4407 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
4409 /* This check filters out values of i that would overflow an int. */
4410 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
4411 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
4413 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
4414 gfc_free_expr (result);
4415 return &gfc_bad_expr;
4418 /* Compute scale = radix ** power. */
4419 power = mpz_get_si (i->value.integer);
4429 gfc_set_model_kind (x->ts.kind);
4432 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
4433 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
4436 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
4438 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
4440 mpfr_clears (scale, radix, NULL);
4442 return range_check (result, "SCALE");
4446 /* Variants of strspn and strcspn that operate on wide characters. */
4449 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
4452 const gfc_char_t *c;
4456 for (c = s2; *c; c++)
4470 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
4473 const gfc_char_t *c;
4477 for (c = s2; *c; c++)
4492 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
4497 size_t indx, len, lenc;
4498 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
4501 return &gfc_bad_expr;
4503 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
4506 if (b != NULL && b->value.logical != 0)
4511 len = e->value.character.length;
4512 lenc = c->value.character.length;
4514 if (len == 0 || lenc == 0)
4522 indx = wide_strcspn (e->value.character.string,
4523 c->value.character.string) + 1;
4530 for (indx = len; indx > 0; indx--)
4532 for (i = 0; i < lenc; i++)
4534 if (c->value.character.string[i]
4535 == e->value.character.string[indx - 1])
4544 result = gfc_get_int_expr (k, &e->where, indx);
4545 return range_check (result, "SCAN");
4550 gfc_simplify_selected_char_kind (gfc_expr *e)
4554 if (e->expr_type != EXPR_CONSTANT)
4557 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
4558 || gfc_compare_with_Cstring (e, "default", false) == 0)
4560 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
4565 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4570 gfc_simplify_selected_int_kind (gfc_expr *e)
4574 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
4579 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
4580 if (gfc_integer_kinds[i].range >= range
4581 && gfc_integer_kinds[i].kind < kind)
4582 kind = gfc_integer_kinds[i].kind;
4584 if (kind == INT_MAX)
4587 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4592 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
4594 int range, precision, i, kind, found_precision, found_range;
4600 if (p->expr_type != EXPR_CONSTANT
4601 || gfc_extract_int (p, &precision) != NULL)
4609 if (q->expr_type != EXPR_CONSTANT
4610 || gfc_extract_int (q, &range) != NULL)
4615 found_precision = 0;
4618 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
4620 if (gfc_real_kinds[i].precision >= precision)
4621 found_precision = 1;
4623 if (gfc_real_kinds[i].range >= range)
4626 if (gfc_real_kinds[i].precision >= precision
4627 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
4628 kind = gfc_real_kinds[i].kind;
4631 if (kind == INT_MAX)
4635 if (!found_precision)
4641 return gfc_get_int_expr (gfc_default_integer_kind,
4642 p ? &p->where : &q->where, kind);
4647 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
4650 mpfr_t exp, absv, log2, pow2, frac;
4653 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4656 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4658 if (mpfr_sgn (x->value.real) == 0)
4660 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4664 gfc_set_model_kind (x->ts.kind);
4671 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
4672 mpfr_log2 (log2, absv, GFC_RND_MODE);
4674 mpfr_trunc (log2, log2);
4675 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
4677 /* Old exponent value, and fraction. */
4678 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
4680 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
4683 exp2 = (unsigned long) mpz_get_d (i->value.integer);
4684 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
4686 mpfr_clears (absv, log2, pow2, frac, NULL);
4688 return range_check (result, "SET_EXPONENT");
4693 gfc_simplify_shape (gfc_expr *source)
4695 mpz_t shape[GFC_MAX_DIMENSIONS];
4696 gfc_expr *result, *e, *f;
4701 if (source->rank == 0)
4702 return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4705 if (source->expr_type != EXPR_VARIABLE)
4708 result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4711 ar = gfc_find_array_ref (source);
4713 t = gfc_array_ref_shape (ar, shape);
4715 for (n = 0; n < source->rank; n++)
4717 e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4722 mpz_set (e->value.integer, shape[n]);
4723 mpz_clear (shape[n]);
4727 mpz_set_ui (e->value.integer, n + 1);
4729 f = gfc_simplify_size (source, e, NULL);
4733 gfc_free_expr (result);
4742 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
4750 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4754 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4757 return &gfc_bad_expr;
4761 if (gfc_array_size (array, &size) == FAILURE)
4766 if (dim->expr_type != EXPR_CONSTANT)
4769 d = mpz_get_ui (dim->value.integer) - 1;
4770 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4774 return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
4779 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4783 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4786 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4791 mpz_abs (result->value.integer, x->value.integer);
4792 if (mpz_sgn (y->value.integer) < 0)
4793 mpz_neg (result->value.integer, result->value.integer);
4797 if (gfc_option.flag_sign_zero)
4798 mpfr_copysign (result->value.real, x->value.real, y->value.real,
4801 mpfr_setsign (result->value.real, x->value.real,
4802 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
4806 gfc_internal_error ("Bad type in gfc_simplify_sign");
4814 gfc_simplify_sin (gfc_expr *x)
4818 if (x->expr_type != EXPR_CONSTANT)
4821 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4826 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4830 gfc_set_model (x->value.real);
4831 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4835 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4838 return range_check (result, "SIN");
4843 gfc_simplify_sinh (gfc_expr *x)
4847 if (x->expr_type != EXPR_CONSTANT)
4850 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4855 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4859 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4866 return range_check (result, "SINH");
4870 /* The argument is always a double precision real that is converted to
4871 single precision. TODO: Rounding! */
4874 gfc_simplify_sngl (gfc_expr *a)
4878 if (a->expr_type != EXPR_CONSTANT)
4881 result = gfc_real2real (a, gfc_default_real_kind);
4882 return range_check (result, "SNGL");
4887 gfc_simplify_spacing (gfc_expr *x)
4893 if (x->expr_type != EXPR_CONSTANT)
4896 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4898 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4900 /* Special case x = 0 and -0. */
4901 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4902 if (mpfr_sgn (result->value.real) == 0)
4904 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4908 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4909 are the radix, exponent of x, and precision. This excludes the
4910 possibility of subnormal numbers. Fortran 2003 states the result is
4911 b**max(e - p, emin - 1). */
4913 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
4914 en = (long int) gfc_real_kinds[i].min_exponent - 1;
4915 en = en > ep ? en : ep;
4917 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
4918 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
4920 return range_check (result, "SPACING");
4925 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
4927 gfc_expr *result = 0L;
4928 int i, j, dim, ncopies;
4931 if ((!gfc_is_constant_expr (source)
4932 && !is_constant_array_expr (source))
4933 || !gfc_is_constant_expr (dim_expr)
4934 || !gfc_is_constant_expr (ncopies_expr))
4937 gcc_assert (dim_expr->ts.type == BT_INTEGER);
4938 gfc_extract_int (dim_expr, &dim);
4939 dim -= 1; /* zero-base DIM */
4941 gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
4942 gfc_extract_int (ncopies_expr, &ncopies);
4943 ncopies = MAX (ncopies, 0);
4945 /* Do not allow the array size to exceed the limit for an array
4947 if (source->expr_type == EXPR_ARRAY)
4949 if (gfc_array_size (source, &size) == FAILURE)
4950 gfc_internal_error ("Failure getting length of a constant array.");
4953 mpz_init_set_ui (size, 1);
4955 if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
4958 if (source->expr_type == EXPR_CONSTANT)
4960 gcc_assert (dim == 0);
4962 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4965 result->shape = gfc_get_shape (result->rank);
4966 mpz_init_set_si (result->shape[0], ncopies);
4968 for (i = 0; i < ncopies; ++i)
4969 gfc_constructor_append_expr (&result->value.constructor,
4970 gfc_copy_expr (source), NULL);
4972 else if (source->expr_type == EXPR_ARRAY)
4974 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
4975 gfc_constructor *source_ctor;
4977 gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
4978 gcc_assert (dim >= 0 && dim <= source->rank);
4980 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4982 result->rank = source->rank + 1;
4983 result->shape = gfc_get_shape (result->rank);
4985 for (i = 0, j = 0; i < result->rank; ++i)
4988 mpz_init_set (result->shape[i], source->shape[j++]);
4990 mpz_init_set_si (result->shape[i], ncopies);
4992 extent[i] = mpz_get_si (result->shape[i]);
4993 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
4997 for (source_ctor = gfc_constructor_first (source->value.constructor);
4998 source_ctor; source_ctor = gfc_constructor_next (source_ctor))
5000 for (i = 0; i < ncopies; ++i)
5001 gfc_constructor_insert_expr (&result->value.constructor,
5002 gfc_copy_expr (source_ctor->expr),
5003 NULL, offset + i * rstride[dim]);
5005 offset += (dim == 0 ? ncopies : 1);
5009 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5010 Replace NULL with gcc_unreachable() after implementing
5011 gfc_simplify_cshift(). */
5014 if (source->ts.type == BT_CHARACTER)
5015 result->ts.u.cl = source->ts.u.cl;
5022 gfc_simplify_sqrt (gfc_expr *e)
5024 gfc_expr *result = NULL;
5026 if (e->expr_type != EXPR_CONSTANT)
5032 if (mpfr_cmp_si (e->value.real, 0) < 0)
5034 gfc_error ("Argument of SQRT at %L has a negative value",
5036 return &gfc_bad_expr;
5038 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5039 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5043 gfc_set_model (e->value.real);
5045 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5046 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
5050 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
5053 return range_check (result, "SQRT");
5058 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5062 if (!is_constant_array_expr (array)
5063 || !gfc_is_constant_expr (dim))
5067 && !is_constant_array_expr (mask)
5068 && mask->expr_type != EXPR_CONSTANT)
5071 result = transformational_result (array, dim, array->ts.type,
5072 array->ts.kind, &array->where);
5073 init_result_expr (result, 0, NULL);
5075 return !dim || array->rank == 1 ?
5076 simplify_transformation_to_scalar (result, array, mask, gfc_add) :
5077 simplify_transformation_to_array (result, array, dim, mask, gfc_add);
5082 gfc_simplify_tan (gfc_expr *x)
5086 if (x->expr_type != EXPR_CONSTANT)
5089 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5094 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
5098 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5105 return range_check (result, "TAN");
5110 gfc_simplify_tanh (gfc_expr *x)
5114 if (x->expr_type != EXPR_CONSTANT)
5117 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5122 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
5126 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5133 return range_check (result, "TANH");
5138 gfc_simplify_tiny (gfc_expr *e)
5143 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5145 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5146 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5153 gfc_simplify_trailz (gfc_expr *e)
5155 unsigned long tz, bs;
5158 if (e->expr_type != EXPR_CONSTANT)
5161 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5162 bs = gfc_integer_kinds[i].bit_size;
5163 tz = mpz_scan1 (e->value.integer, 0);
5165 return gfc_get_int_expr (gfc_default_integer_kind,
5166 &e->where, MIN (tz, bs));
5171 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5174 gfc_expr *mold_element;
5177 size_t result_elt_size;
5180 unsigned char *buffer;
5182 if (!gfc_is_constant_expr (source)
5183 || (gfc_init_expr && !gfc_is_constant_expr (mold))
5184 || !gfc_is_constant_expr (size))
5187 if (source->expr_type == EXPR_FUNCTION)
5190 /* Calculate the size of the source. */
5191 if (source->expr_type == EXPR_ARRAY
5192 && gfc_array_size (source, &tmp) == FAILURE)
5193 gfc_internal_error ("Failure getting length of a constant array.");
5195 source_size = gfc_target_expr_size (source);
5197 /* Create an empty new expression with the appropriate characteristics. */
5198 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
5200 result->ts = mold->ts;
5202 mold_element = mold->expr_type == EXPR_ARRAY
5203 ? gfc_constructor_first (mold->value.constructor)->expr
5206 /* Set result character length, if needed. Note that this needs to be
5207 set even for array expressions, in order to pass this information into
5208 gfc_target_interpret_expr. */
5209 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
5210 result->value.character.length = mold_element->value.character.length;
5212 /* Set the number of elements in the result, and determine its size. */
5213 result_elt_size = gfc_target_expr_size (mold_element);
5214 if (result_elt_size == 0)
5216 gfc_free_expr (result);
5220 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
5224 result->expr_type = EXPR_ARRAY;
5228 result_length = (size_t)mpz_get_ui (size->value.integer);
5231 result_length = source_size / result_elt_size;
5232 if (result_length * result_elt_size < source_size)
5236 result->shape = gfc_get_shape (1);
5237 mpz_init_set_ui (result->shape[0], result_length);
5239 result_size = result_length * result_elt_size;
5244 result_size = result_elt_size;
5247 if (gfc_option.warn_surprising && source_size < result_size)
5248 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
5249 "source size %ld < result size %ld", &source->where,
5250 (long) source_size, (long) result_size);
5252 /* Allocate the buffer to store the binary version of the source. */
5253 buffer_size = MAX (source_size, result_size);
5254 buffer = (unsigned char*)alloca (buffer_size);
5255 memset (buffer, 0, buffer_size);
5257 /* Now write source to the buffer. */
5258 gfc_target_encode_expr (source, buffer, buffer_size);
5260 /* And read the buffer back into the new expression. */
5261 gfc_target_interpret_expr (buffer, buffer_size, result);
5268 gfc_simplify_transpose (gfc_expr *matrix)
5270 int row, matrix_rows, col, matrix_cols;
5273 if (!is_constant_array_expr (matrix))
5276 gcc_assert (matrix->rank == 2);
5278 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
5281 result->shape = gfc_get_shape (result->rank);
5282 mpz_set (result->shape[0], matrix->shape[1]);
5283 mpz_set (result->shape[1], matrix->shape[0]);
5285 if (matrix->ts.type == BT_CHARACTER)
5286 result->ts.u.cl = matrix->ts.u.cl;
5288 matrix_rows = mpz_get_si (matrix->shape[0]);
5289 matrix_cols = mpz_get_si (matrix->shape[1]);
5290 for (row = 0; row < matrix_rows; ++row)
5291 for (col = 0; col < matrix_cols; ++col)
5293 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
5294 col * matrix_rows + row);
5295 gfc_constructor_insert_expr (&result->value.constructor,
5296 gfc_copy_expr (e), &matrix->where,
5297 row * matrix_cols + col);
5305 gfc_simplify_trim (gfc_expr *e)
5308 int count, i, len, lentrim;
5310 if (e->expr_type != EXPR_CONSTANT)
5313 len = e->value.character.length;
5314 for (count = 0, i = 1; i <= len; ++i)
5316 if (e->value.character.string[len - i] == ' ')
5322 lentrim = len - count;
5324 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
5325 for (i = 0; i < lentrim; i++)
5326 result->value.character.string[i] = e->value.character.string[i];
5333 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
5338 gfc_constructor *sub_cons;
5342 if (!is_constant_array_expr (sub))
5343 goto not_implemented; /* return NULL;*/
5345 /* Follow any component references. */
5346 as = coarray->symtree->n.sym->as;
5347 for (ref = coarray->ref; ref; ref = ref->next)
5348 if (ref->type == REF_COMPONENT)
5351 if (as->type == AS_DEFERRED)
5352 goto not_implemented; /* return NULL;*/
5354 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
5355 the cosubscript addresses the first image. */
5357 sub_cons = gfc_constructor_first (sub->value.constructor);
5360 for (d = 1; d <= as->corank; d++)
5365 if (sub_cons == NULL)
5367 gfc_error ("Too few elements in expression for SUB= argument at %L",
5369 return &gfc_bad_expr;
5372 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
5374 if (ca_bound == NULL)
5375 goto not_implemented; /* return NULL */
5377 if (ca_bound == &gfc_bad_expr)
5380 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
5384 gfc_free_expr (ca_bound);
5385 sub_cons = gfc_constructor_next (sub_cons);
5389 first_image = false;
5393 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
5394 "SUB has %ld and COARRAY lower bound is %ld)",
5396 mpz_get_si (sub_cons->expr->value.integer),
5397 mpz_get_si (ca_bound->value.integer));
5398 gfc_free_expr (ca_bound);
5399 return &gfc_bad_expr;
5402 gfc_free_expr (ca_bound);
5404 /* Check whether upperbound is valid for the multi-images case. */
5407 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
5409 if (ca_bound == &gfc_bad_expr)
5412 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
5413 && mpz_cmp (ca_bound->value.integer,
5414 sub_cons->expr->value.integer) < 0)
5416 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
5417 "SUB has %ld and COARRAY upper bound is %ld)",
5419 mpz_get_si (sub_cons->expr->value.integer),
5420 mpz_get_si (ca_bound->value.integer));
5421 gfc_free_expr (ca_bound);
5422 return &gfc_bad_expr;
5426 gfc_free_expr (ca_bound);
5429 sub_cons = gfc_constructor_next (sub_cons);
5432 if (sub_cons != NULL)
5434 gfc_error ("Too many elements in expression for SUB= argument at %L",
5436 return &gfc_bad_expr;
5439 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5440 &gfc_current_locus);
5442 mpz_set_si (result->value.integer, 1);
5444 mpz_set_si (result->value.integer, 0);
5449 gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
5450 "cobounds at %L", &coarray->where);
5451 return &gfc_bad_expr;
5456 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
5462 if (coarray == NULL)
5465 /* FIXME: gfc_current_locus is wrong. */
5466 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5467 &gfc_current_locus);
5468 mpz_set_si (result->value.integer, 1);
5472 gcc_assert (coarray->expr_type == EXPR_VARIABLE);
5474 /* Follow any component references. */
5475 as = coarray->symtree->n.sym->as;
5476 for (ref = coarray->ref; ref; ref = ref->next)
5477 if (ref->type == REF_COMPONENT)
5480 if (as->type == AS_DEFERRED)
5481 goto not_implemented; /* return NULL;*/
5485 /* Multi-dimensional bounds. */
5486 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
5489 /* Simplify the bounds for each dimension. */
5490 for (d = 0; d < as->corank; d++)
5492 bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
5494 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
5498 for (j = 0; j < d; j++)
5499 gfc_free_expr (bounds[j]);
5500 if (bounds[d] == NULL)
5501 goto not_implemented;
5506 /* Allocate the result expression. */
5507 e = gfc_get_expr ();
5508 e->where = coarray->where;
5509 e->expr_type = EXPR_ARRAY;
5510 e->ts.type = BT_INTEGER;
5511 e->ts.kind = gfc_default_integer_kind;
5514 e->shape = gfc_get_shape (1);
5515 mpz_init_set_ui (e->shape[0], as->corank);
5517 /* Create the constructor for this array. */
5518 for (d = 0; d < as->corank; d++)
5519 gfc_constructor_append_expr (&e->value.constructor,
5520 bounds[d], &e->where);
5527 /* A DIM argument is specified. */
5528 if (dim->expr_type != EXPR_CONSTANT)
5529 goto not_implemented; /*return NULL;*/
5531 d = mpz_get_si (dim->value.integer);
5533 if (d < 1 || d > as->corank)
5535 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
5536 return &gfc_bad_expr;
5539 /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
5540 e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
5544 goto not_implemented;
5548 gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
5549 "cobounds at %L", &coarray->where);
5550 return &gfc_bad_expr;
5555 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5557 return simplify_bound (array, dim, kind, 1);
5561 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5564 /* return simplify_cobound (array, dim, kind, 1);*/
5566 e = simplify_cobound (array, dim, kind, 1);
5570 gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
5571 "cobounds at %L", &array->where);
5572 return &gfc_bad_expr;
5577 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
5579 gfc_expr *result, *e;
5580 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
5582 if (!is_constant_array_expr (vector)
5583 || !is_constant_array_expr (mask)
5584 || (!gfc_is_constant_expr (field)
5585 && !is_constant_array_expr(field)))
5588 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
5590 result->rank = mask->rank;
5591 result->shape = gfc_copy_shape (mask->shape, mask->rank);
5593 if (vector->ts.type == BT_CHARACTER)
5594 result->ts.u.cl = vector->ts.u.cl;
5596 vector_ctor = gfc_constructor_first (vector->value.constructor);
5597 mask_ctor = gfc_constructor_first (mask->value.constructor);
5599 = field->expr_type == EXPR_ARRAY
5600 ? gfc_constructor_first (field->value.constructor)
5605 if (mask_ctor->expr->value.logical)
5607 gcc_assert (vector_ctor);
5608 e = gfc_copy_expr (vector_ctor->expr);
5609 vector_ctor = gfc_constructor_next (vector_ctor);
5611 else if (field->expr_type == EXPR_ARRAY)
5612 e = gfc_copy_expr (field_ctor->expr);
5614 e = gfc_copy_expr (field);
5616 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5618 mask_ctor = gfc_constructor_next (mask_ctor);
5619 field_ctor = gfc_constructor_next (field_ctor);
5627 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
5631 size_t index, len, lenset;
5633 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
5636 return &gfc_bad_expr;
5638 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
5641 if (b != NULL && b->value.logical != 0)
5646 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
5648 len = s->value.character.length;
5649 lenset = set->value.character.length;
5653 mpz_set_ui (result->value.integer, 0);
5661 mpz_set_ui (result->value.integer, 1);
5665 index = wide_strspn (s->value.character.string,
5666 set->value.character.string) + 1;
5675 mpz_set_ui (result->value.integer, len);
5678 for (index = len; index > 0; index --)
5680 for (i = 0; i < lenset; i++)
5682 if (s->value.character.string[index - 1]
5683 == set->value.character.string[i])
5691 mpz_set_ui (result->value.integer, index);
5697 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
5702 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5705 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
5710 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
5711 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
5712 return range_check (result, "XOR");
5715 return gfc_get_logical_expr (kind, &x->where,
5716 (x->value.logical && !y->value.logical)
5717 || (!x->value.logical && y->value.logical));
5725 /****************** Constant simplification *****************/
5727 /* Master function to convert one constant to another. While this is
5728 used as a simplification function, it requires the destination type
5729 and kind information which is supplied by a special case in
5733 gfc_convert_constant (gfc_expr *e, bt type, int kind)
5735 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
5750 f = gfc_int2complex;
5770 f = gfc_real2complex;
5781 f = gfc_complex2int;
5784 f = gfc_complex2real;
5787 f = gfc_complex2complex;
5813 f = gfc_hollerith2int;
5817 f = gfc_hollerith2real;
5821 f = gfc_hollerith2complex;
5825 f = gfc_hollerith2character;
5829 f = gfc_hollerith2logical;
5839 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
5844 switch (e->expr_type)
5847 result = f (e, kind);
5849 return &gfc_bad_expr;
5853 if (!gfc_is_constant_expr (e))
5856 result = gfc_get_array_expr (type, kind, &e->where);
5857 result->shape = gfc_copy_shape (e->shape, e->rank);
5858 result->rank = e->rank;
5860 for (c = gfc_constructor_first (e->value.constructor);
5861 c; c = gfc_constructor_next (c))
5864 if (c->iterator == NULL)
5865 tmp = f (c->expr, kind);
5868 g = gfc_convert_constant (c->expr, type, kind);
5869 if (g == &gfc_bad_expr)
5871 gfc_free_expr (result);
5879 gfc_free_expr (result);
5883 gfc_constructor_append_expr (&result->value.constructor,
5897 /* Function for converting character constants. */
5899 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
5904 if (!gfc_is_constant_expr (e))
5907 if (e->expr_type == EXPR_CONSTANT)
5909 /* Simple case of a scalar. */
5910 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
5912 return &gfc_bad_expr;
5914 result->value.character.length = e->value.character.length;
5915 result->value.character.string
5916 = gfc_get_wide_string (e->value.character.length + 1);
5917 memcpy (result->value.character.string, e->value.character.string,
5918 (e->value.character.length + 1) * sizeof (gfc_char_t));
5920 /* Check we only have values representable in the destination kind. */
5921 for (i = 0; i < result->value.character.length; i++)
5922 if (!gfc_check_character_range (result->value.character.string[i],
5925 gfc_error ("Character '%s' in string at %L cannot be converted "
5926 "into character kind %d",
5927 gfc_print_wide_char (result->value.character.string[i]),
5929 return &gfc_bad_expr;
5934 else if (e->expr_type == EXPR_ARRAY)
5936 /* For an array constructor, we convert each constructor element. */
5939 result = gfc_get_array_expr (type, kind, &e->where);
5940 result->shape = gfc_copy_shape (e->shape, e->rank);
5941 result->rank = e->rank;
5942 result->ts.u.cl = e->ts.u.cl;
5944 for (c = gfc_constructor_first (e->value.constructor);
5945 c; c = gfc_constructor_next (c))
5947 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
5948 if (tmp == &gfc_bad_expr)
5950 gfc_free_expr (result);
5951 return &gfc_bad_expr;
5956 gfc_free_expr (result);
5960 gfc_constructor_append_expr (&result->value.constructor,