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_num_images (void)
3874 /* FIXME: gfc_current_locus is wrong. */
3875 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
3876 mpz_set_si (result->value.integer, 1);
3882 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3887 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3890 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3895 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
3896 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3897 return range_check (result, "OR");
3900 return gfc_get_logical_expr (kind, &x->where,
3901 x->value.logical || y->value.logical);
3909 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
3912 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
3914 if (!is_constant_array_expr(array)
3915 || !is_constant_array_expr(vector)
3916 || (!gfc_is_constant_expr (mask)
3917 && !is_constant_array_expr(mask)))
3920 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
3922 array_ctor = gfc_constructor_first (array->value.constructor);
3923 vector_ctor = vector
3924 ? gfc_constructor_first (vector->value.constructor)
3927 if (mask->expr_type == EXPR_CONSTANT
3928 && mask->value.logical)
3930 /* Copy all elements of ARRAY to RESULT. */
3933 gfc_constructor_append_expr (&result->value.constructor,
3934 gfc_copy_expr (array_ctor->expr),
3937 array_ctor = gfc_constructor_next (array_ctor);
3938 vector_ctor = gfc_constructor_next (vector_ctor);
3941 else if (mask->expr_type == EXPR_ARRAY)
3943 /* Copy only those elements of ARRAY to RESULT whose
3944 MASK equals .TRUE.. */
3945 mask_ctor = gfc_constructor_first (mask->value.constructor);
3948 if (mask_ctor->expr->value.logical)
3950 gfc_constructor_append_expr (&result->value.constructor,
3951 gfc_copy_expr (array_ctor->expr),
3953 vector_ctor = gfc_constructor_next (vector_ctor);
3956 array_ctor = gfc_constructor_next (array_ctor);
3957 mask_ctor = gfc_constructor_next (mask_ctor);
3961 /* Append any left-over elements from VECTOR to RESULT. */
3964 gfc_constructor_append_expr (&result->value.constructor,
3965 gfc_copy_expr (vector_ctor->expr),
3967 vector_ctor = gfc_constructor_next (vector_ctor);
3970 result->shape = gfc_get_shape (1);
3971 gfc_array_size (result, &result->shape[0]);
3973 if (array->ts.type == BT_CHARACTER)
3974 result->ts.u.cl = array->ts.u.cl;
3981 gfc_simplify_precision (gfc_expr *e)
3983 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3984 return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3985 gfc_real_kinds[i].precision);
3990 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3994 if (!is_constant_array_expr (array)
3995 || !gfc_is_constant_expr (dim))
3999 && !is_constant_array_expr (mask)
4000 && mask->expr_type != EXPR_CONSTANT)
4003 result = transformational_result (array, dim, array->ts.type,
4004 array->ts.kind, &array->where);
4005 init_result_expr (result, 1, NULL);
4007 return !dim || array->rank == 1 ?
4008 simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
4009 simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
4014 gfc_simplify_radix (gfc_expr *e)
4017 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4022 i = gfc_integer_kinds[i].radix;
4026 i = gfc_real_kinds[i].radix;
4033 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4038 gfc_simplify_range (gfc_expr *e)
4041 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4046 i = gfc_integer_kinds[i].range;
4051 i = gfc_real_kinds[i].range;
4058 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
4063 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
4065 gfc_expr *result = NULL;
4068 if (e->ts.type == BT_COMPLEX)
4069 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4071 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
4074 return &gfc_bad_expr;
4076 if (e->expr_type != EXPR_CONSTANT)
4079 if (convert_boz (e, kind) == &gfc_bad_expr)
4080 return &gfc_bad_expr;
4082 result = gfc_convert_constant (e, BT_REAL, kind);
4083 if (result == &gfc_bad_expr)
4084 return &gfc_bad_expr;
4086 return range_check (result, "REAL");
4091 gfc_simplify_realpart (gfc_expr *e)
4095 if (e->expr_type != EXPR_CONSTANT)
4098 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
4099 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
4101 return range_check (result, "REALPART");
4105 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
4108 int i, j, len, ncop, nlen;
4110 bool have_length = false;
4112 /* If NCOPIES isn't a constant, there's nothing we can do. */
4113 if (n->expr_type != EXPR_CONSTANT)
4116 /* If NCOPIES is negative, it's an error. */
4117 if (mpz_sgn (n->value.integer) < 0)
4119 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4121 return &gfc_bad_expr;
4124 /* If we don't know the character length, we can do no more. */
4125 if (e->ts.u.cl && e->ts.u.cl->length
4126 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
4128 len = mpz_get_si (e->ts.u.cl->length->value.integer);
4131 else if (e->expr_type == EXPR_CONSTANT
4132 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
4134 len = e->value.character.length;
4139 /* If the source length is 0, any value of NCOPIES is valid
4140 and everything behaves as if NCOPIES == 0. */
4143 mpz_set_ui (ncopies, 0);
4145 mpz_set (ncopies, n->value.integer);
4147 /* Check that NCOPIES isn't too large. */
4153 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
4155 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4159 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4160 e->ts.u.cl->length->value.integer);
4164 mpz_init_set_si (mlen, len);
4165 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4169 /* The check itself. */
4170 if (mpz_cmp (ncopies, max) > 0)
4173 mpz_clear (ncopies);
4174 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4176 return &gfc_bad_expr;
4181 mpz_clear (ncopies);
4183 /* For further simplification, we need the character string to be
4185 if (e->expr_type != EXPR_CONSTANT)
4189 (e->ts.u.cl->length &&
4190 mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
4192 const char *res = gfc_extract_int (n, &ncop);
4193 gcc_assert (res == NULL);
4198 len = e->value.character.length;
4201 result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
4204 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
4206 len = e->value.character.length;
4209 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
4210 for (i = 0; i < ncop; i++)
4211 for (j = 0; j < len; j++)
4212 result->value.character.string[j+i*len]= e->value.character.string[j];
4214 result->value.character.string[nlen] = '\0'; /* For debugger */
4219 /* This one is a bear, but mainly has to do with shuffling elements. */
4222 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4223 gfc_expr *pad, gfc_expr *order_exp)
4225 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4226 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
4230 gfc_expr *e, *result;
4232 /* Check that argument expression types are OK. */
4233 if (!is_constant_array_expr (source)
4234 || !is_constant_array_expr (shape_exp)
4235 || !is_constant_array_expr (pad)
4236 || !is_constant_array_expr (order_exp))
4239 /* Proceed with simplification, unpacking the array. */
4246 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
4250 gfc_extract_int (e, &shape[rank]);
4252 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
4253 gcc_assert (shape[rank] >= 0);
4258 gcc_assert (rank > 0);
4260 /* Now unpack the order array if present. */
4261 if (order_exp == NULL)
4263 for (i = 0; i < rank; i++)
4268 for (i = 0; i < rank; i++)
4271 for (i = 0; i < rank; i++)
4273 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
4276 gfc_extract_int (e, &order[i]);
4278 gcc_assert (order[i] >= 1 && order[i] <= rank);
4280 gcc_assert (x[order[i]] == 0);
4285 /* Count the elements in the source and padding arrays. */
4290 gfc_array_size (pad, &size);
4291 npad = mpz_get_ui (size);
4295 gfc_array_size (source, &size);
4296 nsource = mpz_get_ui (size);
4299 /* If it weren't for that pesky permutation we could just loop
4300 through the source and round out any shortage with pad elements.
4301 But no, someone just had to have the compiler do something the
4302 user should be doing. */
4304 for (i = 0; i < rank; i++)
4307 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4309 result->rank = rank;
4310 result->shape = gfc_get_shape (rank);
4311 for (i = 0; i < rank; i++)
4312 mpz_init_set_ui (result->shape[i], shape[i]);
4314 while (nsource > 0 || npad > 0)
4316 /* Figure out which element to extract. */
4317 mpz_set_ui (index, 0);
4319 for (i = rank - 1; i >= 0; i--)
4321 mpz_add_ui (index, index, x[order[i]]);
4323 mpz_mul_ui (index, index, shape[order[i - 1]]);
4326 if (mpz_cmp_ui (index, INT_MAX) > 0)
4327 gfc_internal_error ("Reshaped array too large at %C");
4329 j = mpz_get_ui (index);
4332 e = gfc_constructor_lookup_expr (source->value.constructor, j);
4335 gcc_assert (npad > 0);
4339 e = gfc_constructor_lookup_expr (pad->value.constructor, j);
4343 gfc_constructor_append_expr (&result->value.constructor,
4344 gfc_copy_expr (e), &e->where);
4346 /* Calculate the next element. */
4350 if (++x[i] < shape[i])
4366 gfc_simplify_rrspacing (gfc_expr *x)
4372 if (x->expr_type != EXPR_CONSTANT)
4375 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4377 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4378 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4380 /* Special case x = -0 and 0. */
4381 if (mpfr_sgn (result->value.real) == 0)
4383 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4387 /* | x * 2**(-e) | * 2**p. */
4388 e = - (long int) mpfr_get_exp (x->value.real);
4389 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
4391 p = (long int) gfc_real_kinds[i].digits;
4392 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
4394 return range_check (result, "RRSPACING");
4399 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
4401 int k, neg_flag, power, exp_range;
4402 mpfr_t scale, radix;
4405 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4408 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4410 if (mpfr_sgn (x->value.real) == 0)
4412 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4416 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4418 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
4420 /* This check filters out values of i that would overflow an int. */
4421 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
4422 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
4424 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
4425 gfc_free_expr (result);
4426 return &gfc_bad_expr;
4429 /* Compute scale = radix ** power. */
4430 power = mpz_get_si (i->value.integer);
4440 gfc_set_model_kind (x->ts.kind);
4443 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
4444 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
4447 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
4449 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
4451 mpfr_clears (scale, radix, NULL);
4453 return range_check (result, "SCALE");
4457 /* Variants of strspn and strcspn that operate on wide characters. */
4460 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
4463 const gfc_char_t *c;
4467 for (c = s2; *c; c++)
4481 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
4484 const gfc_char_t *c;
4488 for (c = s2; *c; c++)
4503 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
4508 size_t indx, len, lenc;
4509 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
4512 return &gfc_bad_expr;
4514 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
4517 if (b != NULL && b->value.logical != 0)
4522 len = e->value.character.length;
4523 lenc = c->value.character.length;
4525 if (len == 0 || lenc == 0)
4533 indx = wide_strcspn (e->value.character.string,
4534 c->value.character.string) + 1;
4541 for (indx = len; indx > 0; indx--)
4543 for (i = 0; i < lenc; i++)
4545 if (c->value.character.string[i]
4546 == e->value.character.string[indx - 1])
4555 result = gfc_get_int_expr (k, &e->where, indx);
4556 return range_check (result, "SCAN");
4561 gfc_simplify_selected_char_kind (gfc_expr *e)
4565 if (e->expr_type != EXPR_CONSTANT)
4568 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
4569 || gfc_compare_with_Cstring (e, "default", false) == 0)
4571 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
4576 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4581 gfc_simplify_selected_int_kind (gfc_expr *e)
4585 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
4590 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
4591 if (gfc_integer_kinds[i].range >= range
4592 && gfc_integer_kinds[i].kind < kind)
4593 kind = gfc_integer_kinds[i].kind;
4595 if (kind == INT_MAX)
4598 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4603 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
4605 int range, precision, i, kind, found_precision, found_range;
4611 if (p->expr_type != EXPR_CONSTANT
4612 || gfc_extract_int (p, &precision) != NULL)
4620 if (q->expr_type != EXPR_CONSTANT
4621 || gfc_extract_int (q, &range) != NULL)
4626 found_precision = 0;
4629 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
4631 if (gfc_real_kinds[i].precision >= precision)
4632 found_precision = 1;
4634 if (gfc_real_kinds[i].range >= range)
4637 if (gfc_real_kinds[i].precision >= precision
4638 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
4639 kind = gfc_real_kinds[i].kind;
4642 if (kind == INT_MAX)
4646 if (!found_precision)
4652 return gfc_get_int_expr (gfc_default_integer_kind,
4653 p ? &p->where : &q->where, kind);
4658 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
4661 mpfr_t exp, absv, log2, pow2, frac;
4664 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4667 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4669 if (mpfr_sgn (x->value.real) == 0)
4671 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4675 gfc_set_model_kind (x->ts.kind);
4682 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
4683 mpfr_log2 (log2, absv, GFC_RND_MODE);
4685 mpfr_trunc (log2, log2);
4686 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
4688 /* Old exponent value, and fraction. */
4689 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
4691 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
4694 exp2 = (unsigned long) mpz_get_d (i->value.integer);
4695 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
4697 mpfr_clears (absv, log2, pow2, frac, NULL);
4699 return range_check (result, "SET_EXPONENT");
4704 gfc_simplify_shape (gfc_expr *source)
4706 mpz_t shape[GFC_MAX_DIMENSIONS];
4707 gfc_expr *result, *e, *f;
4712 if (source->rank == 0)
4713 return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4716 if (source->expr_type != EXPR_VARIABLE)
4719 result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4722 ar = gfc_find_array_ref (source);
4724 t = gfc_array_ref_shape (ar, shape);
4726 for (n = 0; n < source->rank; n++)
4728 e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4733 mpz_set (e->value.integer, shape[n]);
4734 mpz_clear (shape[n]);
4738 mpz_set_ui (e->value.integer, n + 1);
4740 f = gfc_simplify_size (source, e, NULL);
4744 gfc_free_expr (result);
4753 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
4761 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4765 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4768 return &gfc_bad_expr;
4772 if (gfc_array_size (array, &size) == FAILURE)
4777 if (dim->expr_type != EXPR_CONSTANT)
4780 d = mpz_get_ui (dim->value.integer) - 1;
4781 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4785 return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
4790 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4794 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4797 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4802 mpz_abs (result->value.integer, x->value.integer);
4803 if (mpz_sgn (y->value.integer) < 0)
4804 mpz_neg (result->value.integer, result->value.integer);
4808 if (gfc_option.flag_sign_zero)
4809 mpfr_copysign (result->value.real, x->value.real, y->value.real,
4812 mpfr_setsign (result->value.real, x->value.real,
4813 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
4817 gfc_internal_error ("Bad type in gfc_simplify_sign");
4825 gfc_simplify_sin (gfc_expr *x)
4829 if (x->expr_type != EXPR_CONSTANT)
4832 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4837 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4841 gfc_set_model (x->value.real);
4842 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4846 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4849 return range_check (result, "SIN");
4854 gfc_simplify_sinh (gfc_expr *x)
4858 if (x->expr_type != EXPR_CONSTANT)
4861 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4866 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4870 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4877 return range_check (result, "SINH");
4881 /* The argument is always a double precision real that is converted to
4882 single precision. TODO: Rounding! */
4885 gfc_simplify_sngl (gfc_expr *a)
4889 if (a->expr_type != EXPR_CONSTANT)
4892 result = gfc_real2real (a, gfc_default_real_kind);
4893 return range_check (result, "SNGL");
4898 gfc_simplify_spacing (gfc_expr *x)
4904 if (x->expr_type != EXPR_CONSTANT)
4907 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4909 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4911 /* Special case x = 0 and -0. */
4912 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4913 if (mpfr_sgn (result->value.real) == 0)
4915 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4919 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4920 are the radix, exponent of x, and precision. This excludes the
4921 possibility of subnormal numbers. Fortran 2003 states the result is
4922 b**max(e - p, emin - 1). */
4924 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
4925 en = (long int) gfc_real_kinds[i].min_exponent - 1;
4926 en = en > ep ? en : ep;
4928 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
4929 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
4931 return range_check (result, "SPACING");
4936 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
4938 gfc_expr *result = 0L;
4939 int i, j, dim, ncopies;
4942 if ((!gfc_is_constant_expr (source)
4943 && !is_constant_array_expr (source))
4944 || !gfc_is_constant_expr (dim_expr)
4945 || !gfc_is_constant_expr (ncopies_expr))
4948 gcc_assert (dim_expr->ts.type == BT_INTEGER);
4949 gfc_extract_int (dim_expr, &dim);
4950 dim -= 1; /* zero-base DIM */
4952 gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
4953 gfc_extract_int (ncopies_expr, &ncopies);
4954 ncopies = MAX (ncopies, 0);
4956 /* Do not allow the array size to exceed the limit for an array
4958 if (source->expr_type == EXPR_ARRAY)
4960 if (gfc_array_size (source, &size) == FAILURE)
4961 gfc_internal_error ("Failure getting length of a constant array.");
4964 mpz_init_set_ui (size, 1);
4966 if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
4969 if (source->expr_type == EXPR_CONSTANT)
4971 gcc_assert (dim == 0);
4973 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4976 result->shape = gfc_get_shape (result->rank);
4977 mpz_init_set_si (result->shape[0], ncopies);
4979 for (i = 0; i < ncopies; ++i)
4980 gfc_constructor_append_expr (&result->value.constructor,
4981 gfc_copy_expr (source), NULL);
4983 else if (source->expr_type == EXPR_ARRAY)
4985 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
4986 gfc_constructor *source_ctor;
4988 gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
4989 gcc_assert (dim >= 0 && dim <= source->rank);
4991 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4993 result->rank = source->rank + 1;
4994 result->shape = gfc_get_shape (result->rank);
4996 for (i = 0, j = 0; i < result->rank; ++i)
4999 mpz_init_set (result->shape[i], source->shape[j++]);
5001 mpz_init_set_si (result->shape[i], ncopies);
5003 extent[i] = mpz_get_si (result->shape[i]);
5004 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
5008 for (source_ctor = gfc_constructor_first (source->value.constructor);
5009 source_ctor; source_ctor = gfc_constructor_next (source_ctor))
5011 for (i = 0; i < ncopies; ++i)
5012 gfc_constructor_insert_expr (&result->value.constructor,
5013 gfc_copy_expr (source_ctor->expr),
5014 NULL, offset + i * rstride[dim]);
5016 offset += (dim == 0 ? ncopies : 1);
5020 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5021 Replace NULL with gcc_unreachable() after implementing
5022 gfc_simplify_cshift(). */
5025 if (source->ts.type == BT_CHARACTER)
5026 result->ts.u.cl = source->ts.u.cl;
5033 gfc_simplify_sqrt (gfc_expr *e)
5035 gfc_expr *result = NULL;
5037 if (e->expr_type != EXPR_CONSTANT)
5043 if (mpfr_cmp_si (e->value.real, 0) < 0)
5045 gfc_error ("Argument of SQRT at %L has a negative value",
5047 return &gfc_bad_expr;
5049 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5050 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5054 gfc_set_model (e->value.real);
5056 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5057 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
5061 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
5064 return range_check (result, "SQRT");
5069 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5073 if (!is_constant_array_expr (array)
5074 || !gfc_is_constant_expr (dim))
5078 && !is_constant_array_expr (mask)
5079 && mask->expr_type != EXPR_CONSTANT)
5082 result = transformational_result (array, dim, array->ts.type,
5083 array->ts.kind, &array->where);
5084 init_result_expr (result, 0, NULL);
5086 return !dim || array->rank == 1 ?
5087 simplify_transformation_to_scalar (result, array, mask, gfc_add) :
5088 simplify_transformation_to_array (result, array, dim, mask, gfc_add);
5093 gfc_simplify_tan (gfc_expr *x)
5097 if (x->expr_type != EXPR_CONSTANT)
5100 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5105 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
5109 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5116 return range_check (result, "TAN");
5121 gfc_simplify_tanh (gfc_expr *x)
5125 if (x->expr_type != EXPR_CONSTANT)
5128 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5133 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
5137 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5144 return range_check (result, "TANH");
5149 gfc_simplify_tiny (gfc_expr *e)
5154 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5156 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5157 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5164 gfc_simplify_trailz (gfc_expr *e)
5166 unsigned long tz, bs;
5169 if (e->expr_type != EXPR_CONSTANT)
5172 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5173 bs = gfc_integer_kinds[i].bit_size;
5174 tz = mpz_scan1 (e->value.integer, 0);
5176 return gfc_get_int_expr (gfc_default_integer_kind,
5177 &e->where, MIN (tz, bs));
5182 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5185 gfc_expr *mold_element;
5188 size_t result_elt_size;
5191 unsigned char *buffer;
5193 if (!gfc_is_constant_expr (source)
5194 || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
5195 || !gfc_is_constant_expr (size))
5198 if (source->expr_type == EXPR_FUNCTION)
5201 /* Calculate the size of the source. */
5202 if (source->expr_type == EXPR_ARRAY
5203 && gfc_array_size (source, &tmp) == FAILURE)
5204 gfc_internal_error ("Failure getting length of a constant array.");
5206 source_size = gfc_target_expr_size (source);
5208 /* Create an empty new expression with the appropriate characteristics. */
5209 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
5211 result->ts = mold->ts;
5213 mold_element = mold->expr_type == EXPR_ARRAY
5214 ? gfc_constructor_first (mold->value.constructor)->expr
5217 /* Set result character length, if needed. Note that this needs to be
5218 set even for array expressions, in order to pass this information into
5219 gfc_target_interpret_expr. */
5220 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
5221 result->value.character.length = mold_element->value.character.length;
5223 /* Set the number of elements in the result, and determine its size. */
5224 result_elt_size = gfc_target_expr_size (mold_element);
5225 if (result_elt_size == 0)
5227 gfc_free_expr (result);
5231 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
5235 result->expr_type = EXPR_ARRAY;
5239 result_length = (size_t)mpz_get_ui (size->value.integer);
5242 result_length = source_size / result_elt_size;
5243 if (result_length * result_elt_size < source_size)
5247 result->shape = gfc_get_shape (1);
5248 mpz_init_set_ui (result->shape[0], result_length);
5250 result_size = result_length * result_elt_size;
5255 result_size = result_elt_size;
5258 if (gfc_option.warn_surprising && source_size < result_size)
5259 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
5260 "source size %ld < result size %ld", &source->where,
5261 (long) source_size, (long) result_size);
5263 /* Allocate the buffer to store the binary version of the source. */
5264 buffer_size = MAX (source_size, result_size);
5265 buffer = (unsigned char*)alloca (buffer_size);
5266 memset (buffer, 0, buffer_size);
5268 /* Now write source to the buffer. */
5269 gfc_target_encode_expr (source, buffer, buffer_size);
5271 /* And read the buffer back into the new expression. */
5272 gfc_target_interpret_expr (buffer, buffer_size, result);
5279 gfc_simplify_transpose (gfc_expr *matrix)
5281 int row, matrix_rows, col, matrix_cols;
5284 if (!is_constant_array_expr (matrix))
5287 gcc_assert (matrix->rank == 2);
5289 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
5292 result->shape = gfc_get_shape (result->rank);
5293 mpz_set (result->shape[0], matrix->shape[1]);
5294 mpz_set (result->shape[1], matrix->shape[0]);
5296 if (matrix->ts.type == BT_CHARACTER)
5297 result->ts.u.cl = matrix->ts.u.cl;
5299 matrix_rows = mpz_get_si (matrix->shape[0]);
5300 matrix_cols = mpz_get_si (matrix->shape[1]);
5301 for (row = 0; row < matrix_rows; ++row)
5302 for (col = 0; col < matrix_cols; ++col)
5304 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
5305 col * matrix_rows + row);
5306 gfc_constructor_insert_expr (&result->value.constructor,
5307 gfc_copy_expr (e), &matrix->where,
5308 row * matrix_cols + col);
5316 gfc_simplify_trim (gfc_expr *e)
5319 int count, i, len, lentrim;
5321 if (e->expr_type != EXPR_CONSTANT)
5324 len = e->value.character.length;
5325 for (count = 0, i = 1; i <= len; ++i)
5327 if (e->value.character.string[len - i] == ' ')
5333 lentrim = len - count;
5335 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
5336 for (i = 0; i < lentrim; i++)
5337 result->value.character.string[i] = e->value.character.string[i];
5344 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
5349 gfc_constructor *sub_cons;
5353 if (!is_constant_array_expr (sub))
5354 goto not_implemented; /* return NULL;*/
5356 /* Follow any component references. */
5357 as = coarray->symtree->n.sym->as;
5358 for (ref = coarray->ref; ref; ref = ref->next)
5359 if (ref->type == REF_COMPONENT)
5362 if (as->type == AS_DEFERRED)
5363 goto not_implemented; /* return NULL;*/
5365 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
5366 the cosubscript addresses the first image. */
5368 sub_cons = gfc_constructor_first (sub->value.constructor);
5371 for (d = 1; d <= as->corank; d++)
5376 if (sub_cons == NULL)
5378 gfc_error ("Too few elements in expression for SUB= argument at %L",
5380 return &gfc_bad_expr;
5383 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
5385 if (ca_bound == NULL)
5386 goto not_implemented; /* return NULL */
5388 if (ca_bound == &gfc_bad_expr)
5391 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
5395 gfc_free_expr (ca_bound);
5396 sub_cons = gfc_constructor_next (sub_cons);
5400 first_image = false;
5404 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
5405 "SUB has %ld and COARRAY lower bound is %ld)",
5407 mpz_get_si (sub_cons->expr->value.integer),
5408 mpz_get_si (ca_bound->value.integer));
5409 gfc_free_expr (ca_bound);
5410 return &gfc_bad_expr;
5413 gfc_free_expr (ca_bound);
5415 /* Check whether upperbound is valid for the multi-images case. */
5418 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
5420 if (ca_bound == &gfc_bad_expr)
5423 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
5424 && mpz_cmp (ca_bound->value.integer,
5425 sub_cons->expr->value.integer) < 0)
5427 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
5428 "SUB has %ld and COARRAY upper bound is %ld)",
5430 mpz_get_si (sub_cons->expr->value.integer),
5431 mpz_get_si (ca_bound->value.integer));
5432 gfc_free_expr (ca_bound);
5433 return &gfc_bad_expr;
5437 gfc_free_expr (ca_bound);
5440 sub_cons = gfc_constructor_next (sub_cons);
5443 if (sub_cons != NULL)
5445 gfc_error ("Too many elements in expression for SUB= argument at %L",
5447 return &gfc_bad_expr;
5450 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5451 &gfc_current_locus);
5453 mpz_set_si (result->value.integer, 1);
5455 mpz_set_si (result->value.integer, 0);
5460 gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
5461 "cobounds at %L", &coarray->where);
5462 return &gfc_bad_expr;
5467 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
5473 if (coarray == NULL)
5476 /* FIXME: gfc_current_locus is wrong. */
5477 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5478 &gfc_current_locus);
5479 mpz_set_si (result->value.integer, 1);
5483 gcc_assert (coarray->expr_type == EXPR_VARIABLE);
5485 /* Follow any component references. */
5486 as = coarray->symtree->n.sym->as;
5487 for (ref = coarray->ref; ref; ref = ref->next)
5488 if (ref->type == REF_COMPONENT)
5491 if (as->type == AS_DEFERRED)
5492 goto not_implemented; /* return NULL;*/
5496 /* Multi-dimensional bounds. */
5497 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
5500 /* Simplify the bounds for each dimension. */
5501 for (d = 0; d < as->corank; d++)
5503 bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
5505 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
5509 for (j = 0; j < d; j++)
5510 gfc_free_expr (bounds[j]);
5511 if (bounds[d] == NULL)
5512 goto not_implemented;
5517 /* Allocate the result expression. */
5518 e = gfc_get_expr ();
5519 e->where = coarray->where;
5520 e->expr_type = EXPR_ARRAY;
5521 e->ts.type = BT_INTEGER;
5522 e->ts.kind = gfc_default_integer_kind;
5525 e->shape = gfc_get_shape (1);
5526 mpz_init_set_ui (e->shape[0], as->corank);
5528 /* Create the constructor for this array. */
5529 for (d = 0; d < as->corank; d++)
5530 gfc_constructor_append_expr (&e->value.constructor,
5531 bounds[d], &e->where);
5538 /* A DIM argument is specified. */
5539 if (dim->expr_type != EXPR_CONSTANT)
5540 goto not_implemented; /*return NULL;*/
5542 d = mpz_get_si (dim->value.integer);
5544 if (d < 1 || d > as->corank)
5546 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
5547 return &gfc_bad_expr;
5550 /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
5551 e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
5555 goto not_implemented;
5559 gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
5560 "cobounds at %L", &coarray->where);
5561 return &gfc_bad_expr;
5566 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5568 return simplify_bound (array, dim, kind, 1);
5572 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5575 /* return simplify_cobound (array, dim, kind, 1);*/
5577 e = simplify_cobound (array, dim, kind, 1);
5581 gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
5582 "cobounds at %L", &array->where);
5583 return &gfc_bad_expr;
5588 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
5590 gfc_expr *result, *e;
5591 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
5593 if (!is_constant_array_expr (vector)
5594 || !is_constant_array_expr (mask)
5595 || (!gfc_is_constant_expr (field)
5596 && !is_constant_array_expr(field)))
5599 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
5601 result->rank = mask->rank;
5602 result->shape = gfc_copy_shape (mask->shape, mask->rank);
5604 if (vector->ts.type == BT_CHARACTER)
5605 result->ts.u.cl = vector->ts.u.cl;
5607 vector_ctor = gfc_constructor_first (vector->value.constructor);
5608 mask_ctor = gfc_constructor_first (mask->value.constructor);
5610 = field->expr_type == EXPR_ARRAY
5611 ? gfc_constructor_first (field->value.constructor)
5616 if (mask_ctor->expr->value.logical)
5618 gcc_assert (vector_ctor);
5619 e = gfc_copy_expr (vector_ctor->expr);
5620 vector_ctor = gfc_constructor_next (vector_ctor);
5622 else if (field->expr_type == EXPR_ARRAY)
5623 e = gfc_copy_expr (field_ctor->expr);
5625 e = gfc_copy_expr (field);
5627 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5629 mask_ctor = gfc_constructor_next (mask_ctor);
5630 field_ctor = gfc_constructor_next (field_ctor);
5638 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
5642 size_t index, len, lenset;
5644 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
5647 return &gfc_bad_expr;
5649 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
5652 if (b != NULL && b->value.logical != 0)
5657 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
5659 len = s->value.character.length;
5660 lenset = set->value.character.length;
5664 mpz_set_ui (result->value.integer, 0);
5672 mpz_set_ui (result->value.integer, 1);
5676 index = wide_strspn (s->value.character.string,
5677 set->value.character.string) + 1;
5686 mpz_set_ui (result->value.integer, len);
5689 for (index = len; index > 0; index --)
5691 for (i = 0; i < lenset; i++)
5693 if (s->value.character.string[index - 1]
5694 == set->value.character.string[i])
5702 mpz_set_ui (result->value.integer, index);
5708 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
5713 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5716 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
5721 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
5722 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
5723 return range_check (result, "XOR");
5726 return gfc_get_logical_expr (kind, &x->where,
5727 (x->value.logical && !y->value.logical)
5728 || (!x->value.logical && y->value.logical));
5736 /****************** Constant simplification *****************/
5738 /* Master function to convert one constant to another. While this is
5739 used as a simplification function, it requires the destination type
5740 and kind information which is supplied by a special case in
5744 gfc_convert_constant (gfc_expr *e, bt type, int kind)
5746 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
5761 f = gfc_int2complex;
5781 f = gfc_real2complex;
5792 f = gfc_complex2int;
5795 f = gfc_complex2real;
5798 f = gfc_complex2complex;
5824 f = gfc_hollerith2int;
5828 f = gfc_hollerith2real;
5832 f = gfc_hollerith2complex;
5836 f = gfc_hollerith2character;
5840 f = gfc_hollerith2logical;
5850 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
5855 switch (e->expr_type)
5858 result = f (e, kind);
5860 return &gfc_bad_expr;
5864 if (!gfc_is_constant_expr (e))
5867 result = gfc_get_array_expr (type, kind, &e->where);
5868 result->shape = gfc_copy_shape (e->shape, e->rank);
5869 result->rank = e->rank;
5871 for (c = gfc_constructor_first (e->value.constructor);
5872 c; c = gfc_constructor_next (c))
5875 if (c->iterator == NULL)
5876 tmp = f (c->expr, kind);
5879 g = gfc_convert_constant (c->expr, type, kind);
5880 if (g == &gfc_bad_expr)
5882 gfc_free_expr (result);
5890 gfc_free_expr (result);
5894 gfc_constructor_append_expr (&result->value.constructor,
5908 /* Function for converting character constants. */
5910 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
5915 if (!gfc_is_constant_expr (e))
5918 if (e->expr_type == EXPR_CONSTANT)
5920 /* Simple case of a scalar. */
5921 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
5923 return &gfc_bad_expr;
5925 result->value.character.length = e->value.character.length;
5926 result->value.character.string
5927 = gfc_get_wide_string (e->value.character.length + 1);
5928 memcpy (result->value.character.string, e->value.character.string,
5929 (e->value.character.length + 1) * sizeof (gfc_char_t));
5931 /* Check we only have values representable in the destination kind. */
5932 for (i = 0; i < result->value.character.length; i++)
5933 if (!gfc_check_character_range (result->value.character.string[i],
5936 gfc_error ("Character '%s' in string at %L cannot be converted "
5937 "into character kind %d",
5938 gfc_print_wide_char (result->value.character.string[i]),
5940 return &gfc_bad_expr;
5945 else if (e->expr_type == EXPR_ARRAY)
5947 /* For an array constructor, we convert each constructor element. */
5950 result = gfc_get_array_expr (type, kind, &e->where);
5951 result->shape = gfc_copy_shape (e->shape, e->rank);
5952 result->rank = e->rank;
5953 result->ts.u.cl = e->ts.u.cl;
5955 for (c = gfc_constructor_first (e->value.constructor);
5956 c; c = gfc_constructor_next (c))
5958 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
5959 if (tmp == &gfc_bad_expr)
5961 gfc_free_expr (result);
5962 return &gfc_bad_expr;
5967 gfc_free_expr (result);
5971 gfc_constructor_append_expr (&result->value.constructor,