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)
2922 unsigned long lz, bs;
2925 if (array->expr_type != EXPR_VARIABLE)
2928 /* Follow any component references. */
2929 as = array->symtree->n.sym->as;
2930 for (ref = array->ref; ref; ref = ref->next)
2935 switch (ref->u.ar.type)
2938 if (ref->next == NULL)
2940 gcc_assert (ref->u.ar.as->corank > 0
2941 && ref->u.ar.as->rank == 0);
2948 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
2961 if (e->expr_type == EXPR_CONSTANT)
2963 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
2964 mpz_set_si (result->value.integer, e->value.character.length);
2965 return range_check (result, "LEN");
2967 else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
2968 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
2969 && e->ts.u.cl->length->ts.type == BT_INTEGER)
2971 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
2972 mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
2973 return range_check (result, "LEN");
2981 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
2985 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
2989 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2992 len = e->value.character.length;
2993 for (count = 0, i = 1; i <= len; i++)
2994 if (e->value.character.string[len - i] == ' ')
2999 result = gfc_get_int_expr (k, &e->where, len - count);
3000 return range_check (result, "LEN_TRIM");
3004 gfc_simplify_lgamma (gfc_expr *x)
3009 if (x->expr_type != EXPR_CONSTANT)
3012 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3013 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
3015 return range_check (result, "LGAMMA");
3020 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
3022 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3025 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3026 gfc_compare_string (a, b) >= 0);
3031 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
3033 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3036 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3037 gfc_compare_string (a, b) > 0);
3042 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
3044 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3047 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3048 gfc_compare_string (a, b) <= 0);
3053 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
3055 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3058 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3059 gfc_compare_string (a, b) < 0);
3064 gfc_simplify_log (gfc_expr *x)
3068 if (x->expr_type != EXPR_CONSTANT)
3071 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3076 if (mpfr_sgn (x->value.real) <= 0)
3078 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3079 "to zero", &x->where);
3080 gfc_free_expr (result);
3081 return &gfc_bad_expr;
3084 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
3088 if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3089 && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
3091 gfc_error ("Complex argument of LOG at %L cannot be zero",
3093 gfc_free_expr (result);
3094 return &gfc_bad_expr;
3097 gfc_set_model_kind (x->ts.kind);
3098 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3102 gfc_internal_error ("gfc_simplify_log: bad type");
3105 return range_check (result, "LOG");
3110 gfc_simplify_log10 (gfc_expr *x)
3114 if (x->expr_type != EXPR_CONSTANT)
3117 if (mpfr_sgn (x->value.real) <= 0)
3119 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3120 "to zero", &x->where);
3121 return &gfc_bad_expr;
3124 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3125 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
3127 return range_check (result, "LOG10");
3132 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
3136 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
3138 return &gfc_bad_expr;
3140 if (e->expr_type != EXPR_CONSTANT)
3143 return gfc_get_logical_expr (kind, &e->where, e->value.logical);
3148 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3151 int row, result_rows, col, result_columns;
3152 int stride_a, offset_a, stride_b, offset_b;
3154 if (!is_constant_array_expr (matrix_a)
3155 || !is_constant_array_expr (matrix_b))
3158 gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
3159 result = gfc_get_array_expr (matrix_a->ts.type,
3163 if (matrix_a->rank == 1 && matrix_b->rank == 2)
3166 result_columns = mpz_get_si (matrix_b->shape[0]);
3168 stride_b = mpz_get_si (matrix_b->shape[0]);
3171 result->shape = gfc_get_shape (result->rank);
3172 mpz_init_set_si (result->shape[0], result_columns);
3174 else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3176 result_rows = mpz_get_si (matrix_b->shape[0]);
3178 stride_a = mpz_get_si (matrix_a->shape[0]);
3182 result->shape = gfc_get_shape (result->rank);
3183 mpz_init_set_si (result->shape[0], result_rows);
3185 else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3187 result_rows = mpz_get_si (matrix_a->shape[0]);
3188 result_columns = mpz_get_si (matrix_b->shape[1]);
3189 stride_a = mpz_get_si (matrix_a->shape[1]);
3190 stride_b = mpz_get_si (matrix_b->shape[0]);
3193 result->shape = gfc_get_shape (result->rank);
3194 mpz_init_set_si (result->shape[0], result_rows);
3195 mpz_init_set_si (result->shape[1], result_columns);
3200 offset_a = offset_b = 0;
3201 for (col = 0; col < result_columns; ++col)
3205 for (row = 0; row < result_rows; ++row)
3207 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
3208 matrix_b, 1, offset_b);
3209 gfc_constructor_append_expr (&result->value.constructor,
3215 offset_b += stride_b;
3223 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3225 if (tsource->expr_type != EXPR_CONSTANT
3226 || fsource->expr_type != EXPR_CONSTANT
3227 || mask->expr_type != EXPR_CONSTANT)
3230 return gfc_copy_expr (mask->value.logical ? tsource : fsource);
3234 /* Selects bewteen current value and extremum for simplify_min_max
3235 and simplify_minval_maxval. */
3237 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
3239 switch (arg->ts.type)
3242 if (mpz_cmp (arg->value.integer,
3243 extremum->value.integer) * sign > 0)
3244 mpz_set (extremum->value.integer, arg->value.integer);
3248 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
3250 mpfr_max (extremum->value.real, extremum->value.real,
3251 arg->value.real, GFC_RND_MODE);
3253 mpfr_min (extremum->value.real, extremum->value.real,
3254 arg->value.real, GFC_RND_MODE);
3258 #define LENGTH(x) ((x)->value.character.length)
3259 #define STRING(x) ((x)->value.character.string)
3260 if (LENGTH(extremum) < LENGTH(arg))
3262 gfc_char_t *tmp = STRING(extremum);
3264 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
3265 memcpy (STRING(extremum), tmp,
3266 LENGTH(extremum) * sizeof (gfc_char_t));
3267 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
3268 LENGTH(arg) - LENGTH(extremum));
3269 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
3270 LENGTH(extremum) = LENGTH(arg);
3274 if (gfc_compare_string (arg, extremum) * sign > 0)
3276 gfc_free (STRING(extremum));
3277 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
3278 memcpy (STRING(extremum), STRING(arg),
3279 LENGTH(arg) * sizeof (gfc_char_t));
3280 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
3281 LENGTH(extremum) - LENGTH(arg));
3282 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
3289 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
3294 /* This function is special since MAX() can take any number of
3295 arguments. The simplified expression is a rewritten version of the
3296 argument list containing at most one constant element. Other
3297 constant elements are deleted. Because the argument list has
3298 already been checked, this function always succeeds. sign is 1 for
3299 MAX(), -1 for MIN(). */
3302 simplify_min_max (gfc_expr *expr, int sign)
3304 gfc_actual_arglist *arg, *last, *extremum;
3305 gfc_intrinsic_sym * specific;
3309 specific = expr->value.function.isym;
3311 arg = expr->value.function.actual;
3313 for (; arg; last = arg, arg = arg->next)
3315 if (arg->expr->expr_type != EXPR_CONSTANT)
3318 if (extremum == NULL)
3324 min_max_choose (arg->expr, extremum->expr, sign);
3326 /* Delete the extra constant argument. */
3328 expr->value.function.actual = arg->next;
3330 last->next = arg->next;
3333 gfc_free_actual_arglist (arg);
3337 /* If there is one value left, replace the function call with the
3339 if (expr->value.function.actual->next != NULL)
3342 /* Convert to the correct type and kind. */
3343 if (expr->ts.type != BT_UNKNOWN)
3344 return gfc_convert_constant (expr->value.function.actual->expr,
3345 expr->ts.type, expr->ts.kind);
3347 if (specific->ts.type != BT_UNKNOWN)
3348 return gfc_convert_constant (expr->value.function.actual->expr,
3349 specific->ts.type, specific->ts.kind);
3351 return gfc_copy_expr (expr->value.function.actual->expr);
3356 gfc_simplify_min (gfc_expr *e)
3358 return simplify_min_max (e, -1);
3363 gfc_simplify_max (gfc_expr *e)
3365 return simplify_min_max (e, 1);
3369 /* This is a simplified version of simplify_min_max to provide
3370 simplification of minval and maxval for a vector. */
3373 simplify_minval_maxval (gfc_expr *expr, int sign)
3375 gfc_constructor *c, *extremum;
3376 gfc_intrinsic_sym * specific;
3379 specific = expr->value.function.isym;
3381 for (c = gfc_constructor_first (expr->value.constructor);
3382 c; c = gfc_constructor_next (c))
3384 if (c->expr->expr_type != EXPR_CONSTANT)
3387 if (extremum == NULL)
3393 min_max_choose (c->expr, extremum->expr, sign);
3396 if (extremum == NULL)
3399 /* Convert to the correct type and kind. */
3400 if (expr->ts.type != BT_UNKNOWN)
3401 return gfc_convert_constant (extremum->expr,
3402 expr->ts.type, expr->ts.kind);
3404 if (specific->ts.type != BT_UNKNOWN)
3405 return gfc_convert_constant (extremum->expr,
3406 specific->ts.type, specific->ts.kind);
3408 return gfc_copy_expr (extremum->expr);
3413 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3415 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3418 return simplify_minval_maxval (array, -1);
3423 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
3425 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
3428 return simplify_minval_maxval (array, 1);
3433 gfc_simplify_maxexponent (gfc_expr *x)
3435 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3436 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3437 gfc_real_kinds[i].max_exponent);
3442 gfc_simplify_minexponent (gfc_expr *x)
3444 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3445 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
3446 gfc_real_kinds[i].min_exponent);
3451 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
3457 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3460 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3461 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3466 if (mpz_cmp_ui (p->value.integer, 0) == 0)
3468 /* Result is processor-dependent. */
3469 gfc_error ("Second argument MOD at %L is zero", &a->where);
3470 gfc_free_expr (result);
3471 return &gfc_bad_expr;
3473 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
3477 if (mpfr_cmp_ui (p->value.real, 0) == 0)
3479 /* Result is processor-dependent. */
3480 gfc_error ("Second argument of MOD at %L is zero", &p->where);
3481 gfc_free_expr (result);
3482 return &gfc_bad_expr;
3485 gfc_set_model_kind (kind);
3487 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3488 mpfr_trunc (tmp, tmp);
3489 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3490 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3495 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
3498 return range_check (result, "MOD");
3503 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
3509 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
3512 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
3513 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
3518 if (mpz_cmp_ui (p->value.integer, 0) == 0)
3520 /* Result is processor-dependent. This processor just opts
3521 to not handle it at all. */
3522 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
3523 gfc_free_expr (result);
3524 return &gfc_bad_expr;
3526 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
3531 if (mpfr_cmp_ui (p->value.real, 0) == 0)
3533 /* Result is processor-dependent. */
3534 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
3535 gfc_free_expr (result);
3536 return &gfc_bad_expr;
3539 gfc_set_model_kind (kind);
3541 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
3542 mpfr_floor (tmp, tmp);
3543 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
3544 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
3549 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
3552 return range_check (result, "MODULO");
3556 /* Exists for the sole purpose of consistency with other intrinsics. */
3558 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
3559 gfc_expr *fp ATTRIBUTE_UNUSED,
3560 gfc_expr *l ATTRIBUTE_UNUSED,
3561 gfc_expr *to ATTRIBUTE_UNUSED,
3562 gfc_expr *tp ATTRIBUTE_UNUSED)
3569 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
3572 mp_exp_t emin, emax;
3575 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3578 if (mpfr_sgn (s->value.real) == 0)
3580 gfc_error ("Second argument of NEAREST at %L shall not be zero",
3582 return &gfc_bad_expr;
3585 result = gfc_copy_expr (x);
3587 /* Save current values of emin and emax. */
3588 emin = mpfr_get_emin ();
3589 emax = mpfr_get_emax ();
3591 /* Set emin and emax for the current model number. */
3592 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
3593 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
3594 mpfr_get_prec(result->value.real) + 1);
3595 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
3596 mpfr_check_range (result->value.real, 0, GMP_RNDU);
3598 if (mpfr_sgn (s->value.real) > 0)
3600 mpfr_nextabove (result->value.real);
3601 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
3605 mpfr_nextbelow (result->value.real);
3606 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
3609 mpfr_set_emin (emin);
3610 mpfr_set_emax (emax);
3612 /* Only NaN can occur. Do not use range check as it gives an
3613 error for denormal numbers. */
3614 if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
3616 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
3617 gfc_free_expr (result);
3618 return &gfc_bad_expr;
3626 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
3628 gfc_expr *itrunc, *result;
3631 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
3633 return &gfc_bad_expr;
3635 if (e->expr_type != EXPR_CONSTANT)
3638 itrunc = gfc_copy_expr (e);
3639 mpfr_round (itrunc->value.real, e->value.real);
3641 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
3642 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
3644 gfc_free_expr (itrunc);
3646 return range_check (result, name);
3651 gfc_simplify_new_line (gfc_expr *e)
3655 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
3656 result->value.character.string[0] = '\n';
3663 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
3665 return simplify_nint ("NINT", e, k);
3670 gfc_simplify_idnint (gfc_expr *e)
3672 return simplify_nint ("IDNINT", e, NULL);
3677 gfc_simplify_not (gfc_expr *e)
3681 if (e->expr_type != EXPR_CONSTANT)
3684 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3685 mpz_com (result->value.integer, e->value.integer);
3687 return range_check (result, "NOT");
3692 gfc_simplify_null (gfc_expr *mold)
3698 result = gfc_copy_expr (mold);
3699 result->expr_type = EXPR_NULL;
3702 result = gfc_get_null_expr (NULL);
3709 gfc_simplify_num_images (void)
3713 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3715 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3716 return &gfc_bad_expr;
3719 /* FIXME: gfc_current_locus is wrong. */
3720 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3721 &gfc_current_locus);
3722 mpz_set_si (result->value.integer, 1);
3728 gfc_simplify_num_images (void)
3731 /* FIXME: gfc_current_locus is wrong. */
3732 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3733 &gfc_current_locus);
3734 mpz_set_si (result->value.integer, 1);
3740 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3745 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3748 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3753 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
3754 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3755 return range_check (result, "OR");
3758 return gfc_get_logical_expr (kind, &x->where,
3759 x->value.logical || y->value.logical);
3767 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
3770 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
3772 if (!is_constant_array_expr(array)
3773 || !is_constant_array_expr(vector)
3774 || (!gfc_is_constant_expr (mask)
3775 && !is_constant_array_expr(mask)))
3778 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
3780 array_ctor = gfc_constructor_first (array->value.constructor);
3781 vector_ctor = vector
3782 ? gfc_constructor_first (vector->value.constructor)
3785 if (mask->expr_type == EXPR_CONSTANT
3786 && mask->value.logical)
3788 /* Copy all elements of ARRAY to RESULT. */
3791 gfc_constructor_append_expr (&result->value.constructor,
3792 gfc_copy_expr (array_ctor->expr),
3795 array_ctor = gfc_constructor_next (array_ctor);
3796 vector_ctor = gfc_constructor_next (vector_ctor);
3799 else if (mask->expr_type == EXPR_ARRAY)
3801 /* Copy only those elements of ARRAY to RESULT whose
3802 MASK equals .TRUE.. */
3803 mask_ctor = gfc_constructor_first (mask->value.constructor);
3806 if (mask_ctor->expr->value.logical)
3808 gfc_constructor_append_expr (&result->value.constructor,
3809 gfc_copy_expr (array_ctor->expr),
3811 vector_ctor = gfc_constructor_next (vector_ctor);
3814 array_ctor = gfc_constructor_next (array_ctor);
3815 mask_ctor = gfc_constructor_next (mask_ctor);
3819 /* Append any left-over elements from VECTOR to RESULT. */
3822 gfc_constructor_append_expr (&result->value.constructor,
3823 gfc_copy_expr (vector_ctor->expr),
3825 vector_ctor = gfc_constructor_next (vector_ctor);
3828 result->shape = gfc_get_shape (1);
3829 gfc_array_size (result, &result->shape[0]);
3831 if (array->ts.type == BT_CHARACTER)
3832 result->ts.u.cl = array->ts.u.cl;
3839 gfc_simplify_precision (gfc_expr *e)
3841 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3842 return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
3843 gfc_real_kinds[i].precision);
3848 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3852 if (!is_constant_array_expr (array)
3853 || !gfc_is_constant_expr (dim))
3857 && !is_constant_array_expr (mask)
3858 && mask->expr_type != EXPR_CONSTANT)
3861 result = transformational_result (array, dim, array->ts.type,
3862 array->ts.kind, &array->where);
3863 init_result_expr (result, 1, NULL);
3865 return !dim || array->rank == 1 ?
3866 simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
3867 simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
3872 gfc_simplify_radix (gfc_expr *e)
3875 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3880 i = gfc_integer_kinds[i].radix;
3884 i = gfc_real_kinds[i].radix;
3891 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
3896 gfc_simplify_range (gfc_expr *e)
3899 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3904 i = gfc_integer_kinds[i].range;
3909 i = gfc_real_kinds[i].range;
3916 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
3921 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
3923 gfc_expr *result = NULL;
3926 if (e->ts.type == BT_COMPLEX)
3927 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
3929 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
3932 return &gfc_bad_expr;
3934 if (e->expr_type != EXPR_CONSTANT)
3937 if (convert_boz (e, kind) == &gfc_bad_expr)
3938 return &gfc_bad_expr;
3940 result = gfc_convert_constant (e, BT_REAL, kind);
3941 if (result == &gfc_bad_expr)
3942 return &gfc_bad_expr;
3944 return range_check (result, "REAL");
3949 gfc_simplify_realpart (gfc_expr *e)
3953 if (e->expr_type != EXPR_CONSTANT)
3956 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
3957 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
3959 return range_check (result, "REALPART");
3963 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
3966 int i, j, len, ncop, nlen;
3968 bool have_length = false;
3970 /* If NCOPIES isn't a constant, there's nothing we can do. */
3971 if (n->expr_type != EXPR_CONSTANT)
3974 /* If NCOPIES is negative, it's an error. */
3975 if (mpz_sgn (n->value.integer) < 0)
3977 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3979 return &gfc_bad_expr;
3982 /* If we don't know the character length, we can do no more. */
3983 if (e->ts.u.cl && e->ts.u.cl->length
3984 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3986 len = mpz_get_si (e->ts.u.cl->length->value.integer);
3989 else if (e->expr_type == EXPR_CONSTANT
3990 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
3992 len = e->value.character.length;
3997 /* If the source length is 0, any value of NCOPIES is valid
3998 and everything behaves as if NCOPIES == 0. */
4001 mpz_set_ui (ncopies, 0);
4003 mpz_set (ncopies, n->value.integer);
4005 /* Check that NCOPIES isn't too large. */
4011 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
4013 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4017 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
4018 e->ts.u.cl->length->value.integer);
4022 mpz_init_set_si (mlen, len);
4023 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4027 /* The check itself. */
4028 if (mpz_cmp (ncopies, max) > 0)
4031 mpz_clear (ncopies);
4032 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4034 return &gfc_bad_expr;
4039 mpz_clear (ncopies);
4041 /* For further simplification, we need the character string to be
4043 if (e->expr_type != EXPR_CONSTANT)
4047 (e->ts.u.cl->length &&
4048 mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
4050 const char *res = gfc_extract_int (n, &ncop);
4051 gcc_assert (res == NULL);
4056 len = e->value.character.length;
4059 result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
4062 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
4064 len = e->value.character.length;
4067 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
4068 for (i = 0; i < ncop; i++)
4069 for (j = 0; j < len; j++)
4070 result->value.character.string[j+i*len]= e->value.character.string[j];
4072 result->value.character.string[nlen] = '\0'; /* For debugger */
4077 /* This one is a bear, but mainly has to do with shuffling elements. */
4080 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4081 gfc_expr *pad, gfc_expr *order_exp)
4083 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4084 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
4088 gfc_expr *e, *result;
4090 /* Check that argument expression types are OK. */
4091 if (!is_constant_array_expr (source)
4092 || !is_constant_array_expr (shape_exp)
4093 || !is_constant_array_expr (pad)
4094 || !is_constant_array_expr (order_exp))
4097 /* Proceed with simplification, unpacking the array. */
4104 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
4108 gfc_extract_int (e, &shape[rank]);
4110 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
4111 gcc_assert (shape[rank] >= 0);
4116 gcc_assert (rank > 0);
4118 /* Now unpack the order array if present. */
4119 if (order_exp == NULL)
4121 for (i = 0; i < rank; i++)
4126 for (i = 0; i < rank; i++)
4129 for (i = 0; i < rank; i++)
4131 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
4134 gfc_extract_int (e, &order[i]);
4136 gcc_assert (order[i] >= 1 && order[i] <= rank);
4138 gcc_assert (x[order[i]] == 0);
4143 /* Count the elements in the source and padding arrays. */
4148 gfc_array_size (pad, &size);
4149 npad = mpz_get_ui (size);
4153 gfc_array_size (source, &size);
4154 nsource = mpz_get_ui (size);
4157 /* If it weren't for that pesky permutation we could just loop
4158 through the source and round out any shortage with pad elements.
4159 But no, someone just had to have the compiler do something the
4160 user should be doing. */
4162 for (i = 0; i < rank; i++)
4165 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4167 result->rank = rank;
4168 result->shape = gfc_get_shape (rank);
4169 for (i = 0; i < rank; i++)
4170 mpz_init_set_ui (result->shape[i], shape[i]);
4172 while (nsource > 0 || npad > 0)
4174 /* Figure out which element to extract. */
4175 mpz_set_ui (index, 0);
4177 for (i = rank - 1; i >= 0; i--)
4179 mpz_add_ui (index, index, x[order[i]]);
4181 mpz_mul_ui (index, index, shape[order[i - 1]]);
4184 if (mpz_cmp_ui (index, INT_MAX) > 0)
4185 gfc_internal_error ("Reshaped array too large at %C");
4187 j = mpz_get_ui (index);
4190 e = gfc_constructor_lookup_expr (source->value.constructor, j);
4193 gcc_assert (npad > 0);
4197 e = gfc_constructor_lookup_expr (pad->value.constructor, j);
4201 gfc_constructor_append_expr (&result->value.constructor,
4202 gfc_copy_expr (e), &e->where);
4204 /* Calculate the next element. */
4208 if (++x[i] < shape[i])
4224 gfc_simplify_rrspacing (gfc_expr *x)
4230 if (x->expr_type != EXPR_CONSTANT)
4233 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4235 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4236 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4238 /* Special case x = -0 and 0. */
4239 if (mpfr_sgn (result->value.real) == 0)
4241 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4245 /* | x * 2**(-e) | * 2**p. */
4246 e = - (long int) mpfr_get_exp (x->value.real);
4247 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
4249 p = (long int) gfc_real_kinds[i].digits;
4250 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
4252 return range_check (result, "RRSPACING");
4257 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
4259 int k, neg_flag, power, exp_range;
4260 mpfr_t scale, radix;
4263 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4266 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4268 if (mpfr_sgn (x->value.real) == 0)
4270 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4274 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4276 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
4278 /* This check filters out values of i that would overflow an int. */
4279 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
4280 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
4282 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
4283 gfc_free_expr (result);
4284 return &gfc_bad_expr;
4287 /* Compute scale = radix ** power. */
4288 power = mpz_get_si (i->value.integer);
4298 gfc_set_model_kind (x->ts.kind);
4301 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
4302 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
4305 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
4307 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
4309 mpfr_clears (scale, radix, NULL);
4311 return range_check (result, "SCALE");
4315 /* Variants of strspn and strcspn that operate on wide characters. */
4318 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
4321 const gfc_char_t *c;
4325 for (c = s2; *c; c++)
4339 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
4342 const gfc_char_t *c;
4346 for (c = s2; *c; c++)
4361 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
4366 size_t indx, len, lenc;
4367 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
4370 return &gfc_bad_expr;
4372 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
4375 if (b != NULL && b->value.logical != 0)
4380 len = e->value.character.length;
4381 lenc = c->value.character.length;
4383 if (len == 0 || lenc == 0)
4391 indx = wide_strcspn (e->value.character.string,
4392 c->value.character.string) + 1;
4399 for (indx = len; indx > 0; indx--)
4401 for (i = 0; i < lenc; i++)
4403 if (c->value.character.string[i]
4404 == e->value.character.string[indx - 1])
4413 result = gfc_get_int_expr (k, &e->where, indx);
4414 return range_check (result, "SCAN");
4419 gfc_simplify_selected_char_kind (gfc_expr *e)
4423 if (e->expr_type != EXPR_CONSTANT)
4426 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
4427 || gfc_compare_with_Cstring (e, "default", false) == 0)
4429 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
4434 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4439 gfc_simplify_selected_int_kind (gfc_expr *e)
4443 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
4448 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
4449 if (gfc_integer_kinds[i].range >= range
4450 && gfc_integer_kinds[i].kind < kind)
4451 kind = gfc_integer_kinds[i].kind;
4453 if (kind == INT_MAX)
4456 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
4461 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
4463 int range, precision, i, kind, found_precision, found_range;
4469 if (p->expr_type != EXPR_CONSTANT
4470 || gfc_extract_int (p, &precision) != NULL)
4478 if (q->expr_type != EXPR_CONSTANT
4479 || gfc_extract_int (q, &range) != NULL)
4484 found_precision = 0;
4487 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
4489 if (gfc_real_kinds[i].precision >= precision)
4490 found_precision = 1;
4492 if (gfc_real_kinds[i].range >= range)
4495 if (gfc_real_kinds[i].precision >= precision
4496 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
4497 kind = gfc_real_kinds[i].kind;
4500 if (kind == INT_MAX)
4504 if (!found_precision)
4510 return gfc_get_int_expr (gfc_default_integer_kind,
4511 p ? &p->where : &q->where, kind);
4516 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
4519 mpfr_t exp, absv, log2, pow2, frac;
4522 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
4525 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4527 if (mpfr_sgn (x->value.real) == 0)
4529 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
4533 gfc_set_model_kind (x->ts.kind);
4540 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
4541 mpfr_log2 (log2, absv, GFC_RND_MODE);
4543 mpfr_trunc (log2, log2);
4544 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
4546 /* Old exponent value, and fraction. */
4547 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
4549 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
4552 exp2 = (unsigned long) mpz_get_d (i->value.integer);
4553 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
4555 mpfr_clears (absv, log2, pow2, frac, NULL);
4557 return range_check (result, "SET_EXPONENT");
4562 gfc_simplify_shape (gfc_expr *source)
4564 mpz_t shape[GFC_MAX_DIMENSIONS];
4565 gfc_expr *result, *e, *f;
4570 if (source->rank == 0)
4571 return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4574 if (source->expr_type != EXPR_VARIABLE)
4577 result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
4580 ar = gfc_find_array_ref (source);
4582 t = gfc_array_ref_shape (ar, shape);
4584 for (n = 0; n < source->rank; n++)
4586 e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4591 mpz_set (e->value.integer, shape[n]);
4592 mpz_clear (shape[n]);
4596 mpz_set_ui (e->value.integer, n + 1);
4598 f = gfc_simplify_size (source, e, NULL);
4602 gfc_free_expr (result);
4611 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
4619 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4623 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4626 return &gfc_bad_expr;
4630 if (gfc_array_size (array, &size) == FAILURE)
4635 if (dim->expr_type != EXPR_CONSTANT)
4638 d = mpz_get_ui (dim->value.integer) - 1;
4639 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4643 return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
4648 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4652 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4655 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4660 mpz_abs (result->value.integer, x->value.integer);
4661 if (mpz_sgn (y->value.integer) < 0)
4662 mpz_neg (result->value.integer, result->value.integer);
4666 if (gfc_option.flag_sign_zero)
4667 mpfr_copysign (result->value.real, x->value.real, y->value.real,
4670 mpfr_setsign (result->value.real, x->value.real,
4671 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
4675 gfc_internal_error ("Bad type in gfc_simplify_sign");
4683 gfc_simplify_sin (gfc_expr *x)
4687 if (x->expr_type != EXPR_CONSTANT)
4690 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4695 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4699 gfc_set_model (x->value.real);
4700 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4704 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4707 return range_check (result, "SIN");
4712 gfc_simplify_sinh (gfc_expr *x)
4716 if (x->expr_type != EXPR_CONSTANT)
4719 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4724 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4728 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4735 return range_check (result, "SINH");
4739 /* The argument is always a double precision real that is converted to
4740 single precision. TODO: Rounding! */
4743 gfc_simplify_sngl (gfc_expr *a)
4747 if (a->expr_type != EXPR_CONSTANT)
4750 result = gfc_real2real (a, gfc_default_real_kind);
4751 return range_check (result, "SNGL");
4756 gfc_simplify_spacing (gfc_expr *x)
4762 if (x->expr_type != EXPR_CONSTANT)
4765 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4767 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
4769 /* Special case x = 0 and -0. */
4770 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4771 if (mpfr_sgn (result->value.real) == 0)
4773 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4777 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4778 are the radix, exponent of x, and precision. This excludes the
4779 possibility of subnormal numbers. Fortran 2003 states the result is
4780 b**max(e - p, emin - 1). */
4782 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
4783 en = (long int) gfc_real_kinds[i].min_exponent - 1;
4784 en = en > ep ? en : ep;
4786 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
4787 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
4789 return range_check (result, "SPACING");
4794 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
4796 gfc_expr *result = 0L;
4797 int i, j, dim, ncopies;
4800 if ((!gfc_is_constant_expr (source)
4801 && !is_constant_array_expr (source))
4802 || !gfc_is_constant_expr (dim_expr)
4803 || !gfc_is_constant_expr (ncopies_expr))
4806 gcc_assert (dim_expr->ts.type == BT_INTEGER);
4807 gfc_extract_int (dim_expr, &dim);
4808 dim -= 1; /* zero-base DIM */
4810 gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
4811 gfc_extract_int (ncopies_expr, &ncopies);
4812 ncopies = MAX (ncopies, 0);
4814 /* Do not allow the array size to exceed the limit for an array
4816 if (source->expr_type == EXPR_ARRAY)
4818 if (gfc_array_size (source, &size) == FAILURE)
4819 gfc_internal_error ("Failure getting length of a constant array.");
4822 mpz_init_set_ui (size, 1);
4824 if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
4827 if (source->expr_type == EXPR_CONSTANT)
4829 gcc_assert (dim == 0);
4831 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4834 result->shape = gfc_get_shape (result->rank);
4835 mpz_init_set_si (result->shape[0], ncopies);
4837 for (i = 0; i < ncopies; ++i)
4838 gfc_constructor_append_expr (&result->value.constructor,
4839 gfc_copy_expr (source), NULL);
4841 else if (source->expr_type == EXPR_ARRAY)
4843 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
4844 gfc_constructor *source_ctor;
4846 gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
4847 gcc_assert (dim >= 0 && dim <= source->rank);
4849 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
4851 result->rank = source->rank + 1;
4852 result->shape = gfc_get_shape (result->rank);
4854 for (i = 0, j = 0; i < result->rank; ++i)
4857 mpz_init_set (result->shape[i], source->shape[j++]);
4859 mpz_init_set_si (result->shape[i], ncopies);
4861 extent[i] = mpz_get_si (result->shape[i]);
4862 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
4866 for (source_ctor = gfc_constructor_first (source->value.constructor);
4867 source_ctor; source_ctor = gfc_constructor_next (source_ctor))
4869 for (i = 0; i < ncopies; ++i)
4870 gfc_constructor_insert_expr (&result->value.constructor,
4871 gfc_copy_expr (source_ctor->expr),
4872 NULL, offset + i * rstride[dim]);
4874 offset += (dim == 0 ? ncopies : 1);
4878 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
4879 Replace NULL with gcc_unreachable() after implementing
4880 gfc_simplify_cshift(). */
4883 if (source->ts.type == BT_CHARACTER)
4884 result->ts.u.cl = source->ts.u.cl;
4891 gfc_simplify_sqrt (gfc_expr *e)
4893 gfc_expr *result = NULL;
4895 if (e->expr_type != EXPR_CONSTANT)
4901 if (mpfr_cmp_si (e->value.real, 0) < 0)
4903 gfc_error ("Argument of SQRT at %L has a negative value",
4905 return &gfc_bad_expr;
4907 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4908 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
4912 gfc_set_model (e->value.real);
4914 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4915 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
4919 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
4922 return range_check (result, "SQRT");
4927 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
4931 if (!is_constant_array_expr (array)
4932 || !gfc_is_constant_expr (dim))
4936 && !is_constant_array_expr (mask)
4937 && mask->expr_type != EXPR_CONSTANT)
4940 result = transformational_result (array, dim, array->ts.type,
4941 array->ts.kind, &array->where);
4942 init_result_expr (result, 0, NULL);
4944 return !dim || array->rank == 1 ?
4945 simplify_transformation_to_scalar (result, array, mask, gfc_add) :
4946 simplify_transformation_to_array (result, array, dim, mask, gfc_add);
4951 gfc_simplify_tan (gfc_expr *x)
4955 if (x->expr_type != EXPR_CONSTANT)
4958 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4963 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
4967 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4974 return range_check (result, "TAN");
4979 gfc_simplify_tanh (gfc_expr *x)
4983 if (x->expr_type != EXPR_CONSTANT)
4986 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4991 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
4995 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5002 return range_check (result, "TANH");
5007 gfc_simplify_tiny (gfc_expr *e)
5012 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
5014 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5015 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5022 gfc_simplify_trailz (gfc_expr *e)
5024 unsigned long tz, bs;
5027 if (e->expr_type != EXPR_CONSTANT)
5030 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5031 bs = gfc_integer_kinds[i].bit_size;
5032 tz = mpz_scan1 (e->value.integer, 0);
5034 return gfc_get_int_expr (gfc_default_integer_kind,
5035 &e->where, MIN (tz, bs));
5040 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
5043 gfc_expr *mold_element;
5046 size_t result_elt_size;
5049 unsigned char *buffer;
5051 if (!gfc_is_constant_expr (source)
5052 || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
5053 || !gfc_is_constant_expr (size))
5056 if (source->expr_type == EXPR_FUNCTION)
5059 /* Calculate the size of the source. */
5060 if (source->expr_type == EXPR_ARRAY
5061 && gfc_array_size (source, &tmp) == FAILURE)
5062 gfc_internal_error ("Failure getting length of a constant array.");
5064 source_size = gfc_target_expr_size (source);
5066 /* Create an empty new expression with the appropriate characteristics. */
5067 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
5069 result->ts = mold->ts;
5071 mold_element = mold->expr_type == EXPR_ARRAY
5072 ? gfc_constructor_first (mold->value.constructor)->expr
5075 /* Set result character length, if needed. Note that this needs to be
5076 set even for array expressions, in order to pass this information into
5077 gfc_target_interpret_expr. */
5078 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
5079 result->value.character.length = mold_element->value.character.length;
5081 /* Set the number of elements in the result, and determine its size. */
5082 result_elt_size = gfc_target_expr_size (mold_element);
5083 if (result_elt_size == 0)
5085 gfc_free_expr (result);
5089 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
5093 result->expr_type = EXPR_ARRAY;
5097 result_length = (size_t)mpz_get_ui (size->value.integer);
5100 result_length = source_size / result_elt_size;
5101 if (result_length * result_elt_size < source_size)
5105 result->shape = gfc_get_shape (1);
5106 mpz_init_set_ui (result->shape[0], result_length);
5108 result_size = result_length * result_elt_size;
5113 result_size = result_elt_size;
5116 if (gfc_option.warn_surprising && source_size < result_size)
5117 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
5118 "source size %ld < result size %ld", &source->where,
5119 (long) source_size, (long) result_size);
5121 /* Allocate the buffer to store the binary version of the source. */
5122 buffer_size = MAX (source_size, result_size);
5123 buffer = (unsigned char*)alloca (buffer_size);
5124 memset (buffer, 0, buffer_size);
5126 /* Now write source to the buffer. */
5127 gfc_target_encode_expr (source, buffer, buffer_size);
5129 /* And read the buffer back into the new expression. */
5130 gfc_target_interpret_expr (buffer, buffer_size, result);
5137 gfc_simplify_transpose (gfc_expr *matrix)
5139 int row, matrix_rows, col, matrix_cols;
5142 if (!is_constant_array_expr (matrix))
5145 gcc_assert (matrix->rank == 2);
5147 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
5150 result->shape = gfc_get_shape (result->rank);
5151 mpz_set (result->shape[0], matrix->shape[1]);
5152 mpz_set (result->shape[1], matrix->shape[0]);
5154 if (matrix->ts.type == BT_CHARACTER)
5155 result->ts.u.cl = matrix->ts.u.cl;
5157 matrix_rows = mpz_get_si (matrix->shape[0]);
5158 matrix_cols = mpz_get_si (matrix->shape[1]);
5159 for (row = 0; row < matrix_rows; ++row)
5160 for (col = 0; col < matrix_cols; ++col)
5162 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
5163 col * matrix_rows + row);
5164 gfc_constructor_insert_expr (&result->value.constructor,
5165 gfc_copy_expr (e), &matrix->where,
5166 row * matrix_cols + col);
5174 gfc_simplify_trim (gfc_expr *e)
5177 int count, i, len, lentrim;
5179 if (e->expr_type != EXPR_CONSTANT)
5182 len = e->value.character.length;
5183 for (count = 0, i = 1; i <= len; ++i)
5185 if (e->value.character.string[len - i] == ' ')
5191 lentrim = len - count;
5193 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
5194 for (i = 0; i < lentrim; i++)
5195 result->value.character.string[i] = e->value.character.string[i];
5200 gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
5201 "cobounds at %L", &coarray->where);
5202 return &gfc_bad_expr;
5207 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
5213 if (coarray == NULL)
5216 /* FIXME: gfc_current_locus is wrong. */
5217 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
5218 &gfc_current_locus);
5219 mpz_set_si (result->value.integer, 1);
5223 gcc_assert (coarray->expr_type == EXPR_VARIABLE);
5225 /* Follow any component references. */
5226 as = coarray->symtree->n.sym->as;
5227 for (ref = coarray->ref; ref; ref = ref->next)
5228 if (ref->type == REF_COMPONENT)
5231 if (as->type == AS_DEFERRED)
5232 goto not_implemented; /* return NULL;*/
5236 /* Multi-dimensional bounds. */
5237 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
5240 /* Simplify the bounds for each dimension. */
5241 for (d = 0; d < as->corank; d++)
5243 bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
5245 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
5249 for (j = 0; j < d; j++)
5250 gfc_free_expr (bounds[j]);
5251 if (bounds[d] == NULL)
5252 goto not_implemented;
5257 /* Allocate the result expression. */
5258 e = gfc_get_expr ();
5259 e->where = coarray->where;
5260 e->expr_type = EXPR_ARRAY;
5261 e->ts.type = BT_INTEGER;
5262 e->ts.kind = gfc_default_integer_kind;
5265 e->shape = gfc_get_shape (1);
5266 mpz_init_set_ui (e->shape[0], as->corank);
5268 /* Create the constructor for this array. */
5269 for (d = 0; d < as->corank; d++)
5270 gfc_constructor_append_expr (&e->value.constructor,
5271 bounds[d], &e->where);
5278 /* A DIM argument is specified. */
5279 if (dim->expr_type != EXPR_CONSTANT)
5280 goto not_implemented; /*return NULL;*/
5282 d = mpz_get_si (dim->value.integer);
5284 if (d < 1 || d > as->corank)
5286 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
5287 return &gfc_bad_expr;
5290 /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
5291 e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
5295 goto not_implemented;
5299 gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
5300 "cobounds at %L", &coarray->where);
5301 return &gfc_bad_expr;
5306 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5308 return simplify_bound (array, dim, kind, 1);
5312 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
5315 /* return simplify_cobound (array, dim, kind, 1);*/
5317 e = simplify_cobound (array, dim, kind, 1);
5321 gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
5322 "cobounds at %L", &array->where);
5323 return &gfc_bad_expr;
5328 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
5330 gfc_expr *result, *e;
5331 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
5333 if (!is_constant_array_expr (vector)
5334 || !is_constant_array_expr (mask)
5335 || (!gfc_is_constant_expr (field)
5336 && !is_constant_array_expr(field)))
5339 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
5341 result->rank = mask->rank;
5342 result->shape = gfc_copy_shape (mask->shape, mask->rank);
5344 if (vector->ts.type == BT_CHARACTER)
5345 result->ts.u.cl = vector->ts.u.cl;
5347 vector_ctor = gfc_constructor_first (vector->value.constructor);
5348 mask_ctor = gfc_constructor_first (mask->value.constructor);
5350 = field->expr_type == EXPR_ARRAY
5351 ? gfc_constructor_first (field->value.constructor)
5356 if (mask_ctor->expr->value.logical)
5358 gcc_assert (vector_ctor);
5359 e = gfc_copy_expr (vector_ctor->expr);
5360 vector_ctor = gfc_constructor_next (vector_ctor);
5362 else if (field->expr_type == EXPR_ARRAY)
5363 e = gfc_copy_expr (field_ctor->expr);
5365 e = gfc_copy_expr (field);
5367 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5369 mask_ctor = gfc_constructor_next (mask_ctor);
5370 field_ctor = gfc_constructor_next (field_ctor);
5378 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
5382 size_t index, len, lenset;
5384 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
5387 return &gfc_bad_expr;
5389 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
5392 if (b != NULL && b->value.logical != 0)
5397 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
5399 len = s->value.character.length;
5400 lenset = set->value.character.length;
5404 mpz_set_ui (result->value.integer, 0);
5412 mpz_set_ui (result->value.integer, 1);
5416 index = wide_strspn (s->value.character.string,
5417 set->value.character.string) + 1;
5426 mpz_set_ui (result->value.integer, len);
5429 for (index = len; index > 0; index --)
5431 for (i = 0; i < lenset; i++)
5433 if (s->value.character.string[index - 1]
5434 == set->value.character.string[i])
5442 mpz_set_ui (result->value.integer, index);
5448 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
5453 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5456 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
5461 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
5462 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
5463 return range_check (result, "XOR");
5466 return gfc_get_logical_expr (kind, &x->where,
5467 (x->value.logical && !y->value.logical)
5468 || (!x->value.logical && y->value.logical));
5476 /****************** Constant simplification *****************/
5478 /* Master function to convert one constant to another. While this is
5479 used as a simplification function, it requires the destination type
5480 and kind information which is supplied by a special case in
5484 gfc_convert_constant (gfc_expr *e, bt type, int kind)
5486 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
5501 f = gfc_int2complex;
5521 f = gfc_real2complex;
5532 f = gfc_complex2int;
5535 f = gfc_complex2real;
5538 f = gfc_complex2complex;
5564 f = gfc_hollerith2int;
5568 f = gfc_hollerith2real;
5572 f = gfc_hollerith2complex;
5576 f = gfc_hollerith2character;
5580 f = gfc_hollerith2logical;
5590 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
5595 switch (e->expr_type)
5598 result = f (e, kind);
5600 return &gfc_bad_expr;
5604 if (!gfc_is_constant_expr (e))
5607 result = gfc_get_array_expr (type, kind, &e->where);
5608 result->shape = gfc_copy_shape (e->shape, e->rank);
5609 result->rank = e->rank;
5611 for (c = gfc_constructor_first (e->value.constructor);
5612 c; c = gfc_constructor_next (c))
5615 if (c->iterator == NULL)
5616 tmp = f (c->expr, kind);
5619 g = gfc_convert_constant (c->expr, type, kind);
5620 if (g == &gfc_bad_expr)
5622 gfc_free_expr (result);
5630 gfc_free_expr (result);
5634 gfc_constructor_append_expr (&result->value.constructor,
5648 /* Function for converting character constants. */
5650 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
5655 if (!gfc_is_constant_expr (e))
5658 if (e->expr_type == EXPR_CONSTANT)
5660 /* Simple case of a scalar. */
5661 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
5663 return &gfc_bad_expr;
5665 result->value.character.length = e->value.character.length;
5666 result->value.character.string
5667 = gfc_get_wide_string (e->value.character.length + 1);
5668 memcpy (result->value.character.string, e->value.character.string,
5669 (e->value.character.length + 1) * sizeof (gfc_char_t));
5671 /* Check we only have values representable in the destination kind. */
5672 for (i = 0; i < result->value.character.length; i++)
5673 if (!gfc_check_character_range (result->value.character.string[i],
5676 gfc_error ("Character '%s' in string at %L cannot be converted "
5677 "into character kind %d",
5678 gfc_print_wide_char (result->value.character.string[i]),
5680 return &gfc_bad_expr;
5685 else if (e->expr_type == EXPR_ARRAY)
5687 /* For an array constructor, we convert each constructor element. */
5690 result = gfc_get_array_expr (type, kind, &e->where);
5691 result->shape = gfc_copy_shape (e->shape, e->rank);
5692 result->rank = e->rank;
5693 result->ts.u.cl = e->ts.u.cl;
5695 for (c = gfc_constructor_first (e->value.constructor);
5696 c; c = gfc_constructor_next (c))
5698 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
5699 if (tmp == &gfc_bad_expr)
5701 gfc_free_expr (result);
5702 return &gfc_bad_expr;
5707 gfc_free_expr (result);
5711 gfc_constructor_append_expr (&result->value.constructor,