1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 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"
30 gfc_expr gfc_bad_expr;
33 /* Note that 'simplification' is not just transforming expressions.
34 For functions that are not simplified at compile time, range
35 checking is done if possible.
37 The return convention is that each simplification function returns:
39 A new expression node corresponding to the simplified arguments.
40 The original arguments are destroyed by the caller, and must not
41 be a part of the new expression.
43 NULL pointer indicating that no simplification was possible and
44 the original expression should remain intact. If the
45 simplification function sets the type and/or the function name
46 via the pointer gfc_simple_expression, then this type is
49 An expression pointer to gfc_bad_expr (a static placeholder)
50 indicating that some error has prevented simplification. For
51 example, sqrt(-1.0). The error is generated within the function
52 and should be propagated upwards
54 By the time a simplification function gets control, it has been
55 decided that the function call is really supposed to be the
56 intrinsic. No type checking is strictly necessary, since only
57 valid types will be passed on. On the other hand, a simplification
58 subroutine may have to look at the type of an argument as part of
61 Array arguments are never passed to these subroutines.
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 /* Helper function to get an integer constant with a kind number given
136 by an integer constant expression. */
138 int_expr_with_kind (int i, gfc_expr *kind, const char *name)
140 gfc_expr *res = gfc_int_expr (i);
141 res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind);
142 if (res->ts.kind == -1)
149 /* Converts an mpz_t signed variable into an unsigned one, assuming
150 two's complement representations and a binary width of bitsize.
151 The conversion is a no-op unless x is negative; otherwise, it can
152 be accomplished by masking out the high bits. */
155 convert_mpz_to_unsigned (mpz_t x, int bitsize)
161 /* Confirm that no bits above the signed range are unset. */
162 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
164 mpz_init_set_ui (mask, 1);
165 mpz_mul_2exp (mask, mask, bitsize);
166 mpz_sub_ui (mask, mask, 1);
168 mpz_and (x, x, mask);
174 /* Confirm that no bits above the signed range are set. */
175 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
180 /* Converts an mpz_t unsigned variable into a signed one, assuming
181 two's complement representations and a binary width of bitsize.
182 If the bitsize-1 bit is set, this is taken as a sign bit and
183 the number is converted to the corresponding negative number. */
186 convert_mpz_to_signed (mpz_t x, int bitsize)
190 /* Confirm that no bits above the unsigned range are set. */
191 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
193 if (mpz_tstbit (x, bitsize - 1) == 1)
195 mpz_init_set_ui (mask, 1);
196 mpz_mul_2exp (mask, mask, bitsize);
197 mpz_sub_ui (mask, mask, 1);
199 /* We negate the number by hand, zeroing the high bits, that is
200 make it the corresponding positive number, and then have it
201 negated by GMP, giving the correct representation of the
204 mpz_add_ui (x, x, 1);
205 mpz_and (x, x, mask);
214 /********************** Simplification functions *****************************/
217 gfc_simplify_abs (gfc_expr *e)
221 if (e->expr_type != EXPR_CONSTANT)
227 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
229 mpz_abs (result->value.integer, e->value.integer);
231 result = range_check (result, "IABS");
235 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
237 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
239 result = range_check (result, "ABS");
243 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
245 gfc_set_model_kind (e->ts.kind);
247 mpfr_hypot (result->value.real, e->value.complex.r,
248 e->value.complex.i, GFC_RND_MODE);
249 result = range_check (result, "CABS");
253 gfc_internal_error ("gfc_simplify_abs(): Bad type");
259 /* We use the processor's collating sequence, because all
260 systems that gfortran currently works on are ASCII. */
263 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
269 if (e->expr_type != EXPR_CONSTANT)
272 kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind);
274 return &gfc_bad_expr;
276 ch = gfc_extract_int (e, &c);
279 gfc_internal_error ("gfc_simplify_achar: %s", ch);
281 if (gfc_option.warn_surprising && (c < 0 || c > 127))
282 gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
285 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
287 result->value.character.string = gfc_getmem (2);
289 result->value.character.length = 1;
290 result->value.character.string[0] = c;
291 result->value.character.string[1] = '\0'; /* For debugger */
297 gfc_simplify_acos (gfc_expr *x)
301 if (x->expr_type != EXPR_CONSTANT)
304 if (mpfr_cmp_si (x->value.real, 1) > 0
305 || mpfr_cmp_si (x->value.real, -1) < 0)
307 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
309 return &gfc_bad_expr;
312 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
314 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
316 return range_check (result, "ACOS");
320 gfc_simplify_acosh (gfc_expr *x)
324 if (x->expr_type != EXPR_CONSTANT)
327 if (mpfr_cmp_si (x->value.real, 1) < 0)
329 gfc_error ("Argument of ACOSH at %L must not be less than 1",
331 return &gfc_bad_expr;
334 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
336 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
338 return range_check (result, "ACOSH");
342 gfc_simplify_adjustl (gfc_expr *e)
348 if (e->expr_type != EXPR_CONSTANT)
351 len = e->value.character.length;
353 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
355 result->value.character.length = len;
356 result->value.character.string = gfc_getmem (len + 1);
358 for (count = 0, i = 0; i < len; ++i)
360 ch = e->value.character.string[i];
366 for (i = 0; i < len - count; ++i)
367 result->value.character.string[i] = e->value.character.string[count + i];
369 for (i = len - count; i < len; ++i)
370 result->value.character.string[i] = ' ';
372 result->value.character.string[len] = '\0'; /* For debugger */
379 gfc_simplify_adjustr (gfc_expr *e)
385 if (e->expr_type != EXPR_CONSTANT)
388 len = e->value.character.length;
390 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
392 result->value.character.length = len;
393 result->value.character.string = gfc_getmem (len + 1);
395 for (count = 0, i = len - 1; i >= 0; --i)
397 ch = e->value.character.string[i];
403 for (i = 0; i < count; ++i)
404 result->value.character.string[i] = ' ';
406 for (i = count; i < len; ++i)
407 result->value.character.string[i] = e->value.character.string[i - count];
409 result->value.character.string[len] = '\0'; /* For debugger */
416 gfc_simplify_aimag (gfc_expr *e)
420 if (e->expr_type != EXPR_CONSTANT)
423 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
424 mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
426 return range_check (result, "AIMAG");
431 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
433 gfc_expr *rtrunc, *result;
436 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
438 return &gfc_bad_expr;
440 if (e->expr_type != EXPR_CONSTANT)
443 rtrunc = gfc_copy_expr (e);
445 mpfr_trunc (rtrunc->value.real, e->value.real);
447 result = gfc_real2real (rtrunc, kind);
448 gfc_free_expr (rtrunc);
450 return range_check (result, "AINT");
455 gfc_simplify_dint (gfc_expr *e)
457 gfc_expr *rtrunc, *result;
459 if (e->expr_type != EXPR_CONSTANT)
462 rtrunc = gfc_copy_expr (e);
464 mpfr_trunc (rtrunc->value.real, e->value.real);
466 result = gfc_real2real (rtrunc, gfc_default_double_kind);
467 gfc_free_expr (rtrunc);
469 return range_check (result, "DINT");
474 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
479 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
481 return &gfc_bad_expr;
483 if (e->expr_type != EXPR_CONSTANT)
486 result = gfc_constant_result (e->ts.type, kind, &e->where);
488 mpfr_round (result->value.real, e->value.real);
490 return range_check (result, "ANINT");
495 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
500 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
503 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
504 if (x->ts.type == BT_INTEGER)
506 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
507 mpz_and (result->value.integer, x->value.integer, y->value.integer);
509 else /* BT_LOGICAL */
511 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
512 result->value.logical = x->value.logical && y->value.logical;
515 return range_check (result, "AND");
520 gfc_simplify_dnint (gfc_expr *e)
524 if (e->expr_type != EXPR_CONSTANT)
527 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
529 mpfr_round (result->value.real, e->value.real);
531 return range_check (result, "DNINT");
536 gfc_simplify_asin (gfc_expr *x)
540 if (x->expr_type != EXPR_CONSTANT)
543 if (mpfr_cmp_si (x->value.real, 1) > 0
544 || mpfr_cmp_si (x->value.real, -1) < 0)
546 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
548 return &gfc_bad_expr;
551 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
553 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
555 return range_check (result, "ASIN");
560 gfc_simplify_asinh (gfc_expr *x)
564 if (x->expr_type != EXPR_CONSTANT)
567 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
569 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
571 return range_check (result, "ASINH");
576 gfc_simplify_atan (gfc_expr *x)
580 if (x->expr_type != EXPR_CONSTANT)
583 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
585 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
587 return range_check (result, "ATAN");
592 gfc_simplify_atanh (gfc_expr *x)
596 if (x->expr_type != EXPR_CONSTANT)
599 if (mpfr_cmp_si (x->value.real, 1) >= 0
600 || mpfr_cmp_si (x->value.real, -1) <= 0)
602 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
604 return &gfc_bad_expr;
607 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
609 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
611 return range_check (result, "ATANH");
616 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
620 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
623 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
625 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
627 gfc_error ("If first argument of ATAN2 %L is zero, then the "
628 "second argument must not be zero", &x->where);
629 gfc_free_expr (result);
630 return &gfc_bad_expr;
633 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
635 return range_check (result, "ATAN2");
640 gfc_simplify_bit_size (gfc_expr *e)
645 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
646 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
647 mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
654 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
658 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
661 if (gfc_extract_int (bit, &b) != NULL || b < 0)
662 return gfc_logical_expr (0, &e->where);
664 return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
669 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
671 gfc_expr *ceil, *result;
674 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
676 return &gfc_bad_expr;
678 if (e->expr_type != EXPR_CONSTANT)
681 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
683 ceil = gfc_copy_expr (e);
685 mpfr_ceil (ceil->value.real, e->value.real);
686 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
688 gfc_free_expr (ceil);
690 return range_check (result, "CEILING");
695 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
701 kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
703 return &gfc_bad_expr;
705 if (e->expr_type != EXPR_CONSTANT)
708 ch = gfc_extract_int (e, &c);
711 gfc_internal_error ("gfc_simplify_char: %s", ch);
713 if (c < 0 || c > UCHAR_MAX)
714 gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
717 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
719 result->value.character.length = 1;
720 result->value.character.string = gfc_getmem (2);
722 result->value.character.string[0] = c;
723 result->value.character.string[1] = '\0'; /* For debugger */
729 /* Common subroutine for simplifying CMPLX and DCMPLX. */
732 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
736 result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
738 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
744 mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
748 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
752 mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
753 mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
757 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
766 mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
770 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
774 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
783 ts.kind = result->ts.kind;
785 if (!gfc_convert_boz (x, &ts))
786 return &gfc_bad_expr;
787 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
794 ts.kind = result->ts.kind;
796 if (!gfc_convert_boz (y, &ts))
797 return &gfc_bad_expr;
798 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
801 return range_check (result, name);
806 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
810 if (x->expr_type != EXPR_CONSTANT
811 || (y != NULL && y->expr_type != EXPR_CONSTANT))
814 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
816 return &gfc_bad_expr;
818 return simplify_cmplx ("CMPLX", x, y, kind);
823 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
827 if (x->expr_type != EXPR_CONSTANT
828 || (y != NULL && y->expr_type != EXPR_CONSTANT))
831 if (x->ts.type == BT_INTEGER)
833 if (y->ts.type == BT_INTEGER)
834 kind = gfc_default_real_kind;
840 if (y->ts.type == BT_REAL)
841 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
846 return simplify_cmplx ("COMPLEX", x, y, kind);
851 gfc_simplify_conjg (gfc_expr *e)
855 if (e->expr_type != EXPR_CONSTANT)
858 result = gfc_copy_expr (e);
859 mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
861 return range_check (result, "CONJG");
866 gfc_simplify_cos (gfc_expr *x)
871 if (x->expr_type != EXPR_CONSTANT)
874 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
879 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
882 gfc_set_model_kind (x->ts.kind);
886 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
887 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
888 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
890 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
891 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
892 mpfr_mul (xp, xp, xq, GFC_RND_MODE);
893 mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
899 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
902 return range_check (result, "COS");
908 gfc_simplify_cosh (gfc_expr *x)
912 if (x->expr_type != EXPR_CONSTANT)
915 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
917 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
919 return range_check (result, "COSH");
924 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
927 if (x->expr_type != EXPR_CONSTANT
928 || (y != NULL && y->expr_type != EXPR_CONSTANT))
931 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
936 gfc_simplify_dble (gfc_expr *e)
940 if (e->expr_type != EXPR_CONSTANT)
947 result = gfc_int2real (e, gfc_default_double_kind);
951 result = gfc_real2real (e, gfc_default_double_kind);
955 result = gfc_complex2real (e, gfc_default_double_kind);
959 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
962 if (e->ts.type == BT_INTEGER && e->is_boz)
967 ts.kind = gfc_default_double_kind;
968 result = gfc_copy_expr (e);
969 if (!gfc_convert_boz (result, &ts))
970 return &gfc_bad_expr;
973 return range_check (result, "DBLE");
978 gfc_simplify_digits (gfc_expr *x)
982 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
986 digits = gfc_integer_kinds[i].digits;
991 digits = gfc_real_kinds[i].digits;
998 return gfc_int_expr (digits);
1003 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1008 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1011 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1012 result = gfc_constant_result (x->ts.type, kind, &x->where);
1017 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1018 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1020 mpz_set_ui (result->value.integer, 0);
1025 if (mpfr_cmp (x->value.real, y->value.real) > 0)
1026 mpfr_sub (result->value.real, x->value.real, y->value.real,
1029 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1034 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1037 return range_check (result, "DIM");
1042 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1044 gfc_expr *a1, *a2, *result;
1046 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1049 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1051 a1 = gfc_real2real (x, gfc_default_double_kind);
1052 a2 = gfc_real2real (y, gfc_default_double_kind);
1054 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1059 return range_check (result, "DPROD");
1064 gfc_simplify_erf (gfc_expr *x)
1068 if (x->expr_type != EXPR_CONSTANT)
1071 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1073 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1075 return range_check (result, "ERF");
1080 gfc_simplify_erfc (gfc_expr *x)
1084 if (x->expr_type != EXPR_CONSTANT)
1087 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1089 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1091 return range_check (result, "ERFC");
1096 gfc_simplify_epsilon (gfc_expr *e)
1101 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1103 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1105 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1107 return range_check (result, "EPSILON");
1112 gfc_simplify_exp (gfc_expr *x)
1117 if (x->expr_type != EXPR_CONSTANT)
1120 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1125 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1129 gfc_set_model_kind (x->ts.kind);
1132 mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1133 mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1134 mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1135 mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1136 mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1142 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1145 return range_check (result, "EXP");
1149 gfc_simplify_exponent (gfc_expr *x)
1154 if (x->expr_type != EXPR_CONSTANT)
1157 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1160 gfc_set_model (x->value.real);
1162 if (mpfr_sgn (x->value.real) == 0)
1164 mpz_set_ui (result->value.integer, 0);
1168 i = (int) mpfr_get_exp (x->value.real);
1169 mpz_set_si (result->value.integer, i);
1171 return range_check (result, "EXPONENT");
1176 gfc_simplify_float (gfc_expr *a)
1180 if (a->expr_type != EXPR_CONSTANT)
1189 ts.kind = gfc_default_real_kind;
1191 result = gfc_copy_expr (a);
1192 if (!gfc_convert_boz (result, &ts))
1193 return &gfc_bad_expr;
1196 result = gfc_int2real (a, gfc_default_real_kind);
1197 return range_check (result, "FLOAT");
1202 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1208 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1210 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1212 if (e->expr_type != EXPR_CONSTANT)
1215 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1217 gfc_set_model_kind (kind);
1219 mpfr_floor (floor, e->value.real);
1221 gfc_mpfr_to_mpz (result->value.integer, floor);
1225 return range_check (result, "FLOOR");
1230 gfc_simplify_fraction (gfc_expr *x)
1233 mpfr_t absv, exp, pow2;
1235 if (x->expr_type != EXPR_CONSTANT)
1238 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1240 gfc_set_model_kind (x->ts.kind);
1242 if (mpfr_sgn (x->value.real) == 0)
1244 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1252 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1253 mpfr_log2 (exp, absv, GFC_RND_MODE);
1255 mpfr_trunc (exp, exp);
1256 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1258 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1260 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1266 return range_check (result, "FRACTION");
1271 gfc_simplify_gamma (gfc_expr *x)
1275 if (x->expr_type != EXPR_CONSTANT)
1278 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1280 gfc_set_model_kind (x->ts.kind);
1282 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1284 return range_check (result, "GAMMA");
1289 gfc_simplify_huge (gfc_expr *e)
1294 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1296 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1301 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1305 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1317 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
1321 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1324 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1325 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
1326 return range_check (result, "HYPOT");
1330 /* We use the processor's collating sequence, because all
1331 systems that gfortran currently works on are ASCII. */
1334 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
1339 if (e->expr_type != EXPR_CONSTANT)
1342 if (e->value.character.length != 1)
1344 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1345 return &gfc_bad_expr;
1348 index = (unsigned char) e->value.character.string[0];
1350 if (gfc_option.warn_surprising && index > 127)
1351 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1354 if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
1355 return &gfc_bad_expr;
1357 result->where = e->where;
1359 return range_check (result, "IACHAR");
1364 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1368 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1371 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1373 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1375 return range_check (result, "IAND");
1380 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1385 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1388 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1390 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1391 return &gfc_bad_expr;
1394 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1396 if (pos >= gfc_integer_kinds[k].bit_size)
1398 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1400 return &gfc_bad_expr;
1403 result = gfc_copy_expr (x);
1405 convert_mpz_to_unsigned (result->value.integer,
1406 gfc_integer_kinds[k].bit_size);
1408 mpz_clrbit (result->value.integer, pos);
1410 convert_mpz_to_signed (result->value.integer,
1411 gfc_integer_kinds[k].bit_size);
1418 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1425 if (x->expr_type != EXPR_CONSTANT
1426 || y->expr_type != EXPR_CONSTANT
1427 || z->expr_type != EXPR_CONSTANT)
1430 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1432 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1433 return &gfc_bad_expr;
1436 if (gfc_extract_int (z, &len) != NULL || len < 0)
1438 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1439 return &gfc_bad_expr;
1442 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1444 bitsize = gfc_integer_kinds[k].bit_size;
1446 if (pos + len > bitsize)
1448 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1449 "bit size at %L", &y->where);
1450 return &gfc_bad_expr;
1453 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1454 convert_mpz_to_unsigned (result->value.integer,
1455 gfc_integer_kinds[k].bit_size);
1457 bits = gfc_getmem (bitsize * sizeof (int));
1459 for (i = 0; i < bitsize; i++)
1462 for (i = 0; i < len; i++)
1463 bits[i] = mpz_tstbit (x->value.integer, i + pos);
1465 for (i = 0; i < bitsize; i++)
1468 mpz_clrbit (result->value.integer, i);
1469 else if (bits[i] == 1)
1470 mpz_setbit (result->value.integer, i);
1472 gfc_internal_error ("IBITS: Bad bit");
1477 convert_mpz_to_signed (result->value.integer,
1478 gfc_integer_kinds[k].bit_size);
1485 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1490 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1493 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1495 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1496 return &gfc_bad_expr;
1499 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1501 if (pos >= gfc_integer_kinds[k].bit_size)
1503 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1505 return &gfc_bad_expr;
1508 result = gfc_copy_expr (x);
1510 convert_mpz_to_unsigned (result->value.integer,
1511 gfc_integer_kinds[k].bit_size);
1513 mpz_setbit (result->value.integer, pos);
1515 convert_mpz_to_signed (result->value.integer,
1516 gfc_integer_kinds[k].bit_size);
1523 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
1528 if (e->expr_type != EXPR_CONSTANT)
1531 if (e->value.character.length != 1)
1533 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1534 return &gfc_bad_expr;
1537 index = (unsigned char) e->value.character.string[0];
1539 if (index < 0 || index > UCHAR_MAX)
1540 gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
1542 if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
1543 return &gfc_bad_expr;
1545 result->where = e->where;
1546 return range_check (result, "ICHAR");
1551 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
1555 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1558 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1560 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1562 return range_check (result, "IEOR");
1567 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
1570 int back, len, lensub;
1571 int i, j, k, count, index = 0, start;
1573 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1576 if (b != NULL && b->value.logical != 0)
1581 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
1583 return &gfc_bad_expr;
1585 result = gfc_constant_result (BT_INTEGER, k, &x->where);
1587 len = x->value.character.length;
1588 lensub = y->value.character.length;
1592 mpz_set_si (result->value.integer, 0);
1600 mpz_set_si (result->value.integer, 1);
1603 else if (lensub == 1)
1605 for (i = 0; i < len; i++)
1607 for (j = 0; j < lensub; j++)
1609 if (y->value.character.string[j]
1610 == x->value.character.string[i])
1620 for (i = 0; i < len; i++)
1622 for (j = 0; j < lensub; j++)
1624 if (y->value.character.string[j]
1625 == x->value.character.string[i])
1630 for (k = 0; k < lensub; k++)
1632 if (y->value.character.string[k]
1633 == x->value.character.string[k + start])
1637 if (count == lensub)
1652 mpz_set_si (result->value.integer, len + 1);
1655 else if (lensub == 1)
1657 for (i = 0; i < len; i++)
1659 for (j = 0; j < lensub; j++)
1661 if (y->value.character.string[j]
1662 == x->value.character.string[len - i])
1664 index = len - i + 1;
1672 for (i = 0; i < len; i++)
1674 for (j = 0; j < lensub; j++)
1676 if (y->value.character.string[j]
1677 == x->value.character.string[len - i])
1680 if (start <= len - lensub)
1683 for (k = 0; k < lensub; k++)
1684 if (y->value.character.string[k]
1685 == x->value.character.string[k + start])
1688 if (count == lensub)
1705 mpz_set_si (result->value.integer, index);
1706 return range_check (result, "INDEX");
1711 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
1713 gfc_expr *rpart, *rtrunc, *result;
1716 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1718 return &gfc_bad_expr;
1720 if (e->expr_type != EXPR_CONSTANT)
1723 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1728 mpz_set (result->value.integer, e->value.integer);
1732 rtrunc = gfc_copy_expr (e);
1733 mpfr_trunc (rtrunc->value.real, e->value.real);
1734 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1735 gfc_free_expr (rtrunc);
1739 rpart = gfc_complex2real (e, kind);
1740 rtrunc = gfc_copy_expr (rpart);
1741 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1742 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1743 gfc_free_expr (rpart);
1744 gfc_free_expr (rtrunc);
1748 gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1749 gfc_free_expr (result);
1750 return &gfc_bad_expr;
1753 return range_check (result, "INT");
1758 gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
1760 gfc_expr *rpart, *rtrunc, *result;
1762 if (e->expr_type != EXPR_CONSTANT)
1765 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1770 mpz_set (result->value.integer, e->value.integer);
1774 rtrunc = gfc_copy_expr (e);
1775 mpfr_trunc (rtrunc->value.real, e->value.real);
1776 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1777 gfc_free_expr (rtrunc);
1781 rpart = gfc_complex2real (e, kind);
1782 rtrunc = gfc_copy_expr (rpart);
1783 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1784 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1785 gfc_free_expr (rpart);
1786 gfc_free_expr (rtrunc);
1790 gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
1791 gfc_free_expr (result);
1792 return &gfc_bad_expr;
1795 return range_check (result, name);
1800 gfc_simplify_int2 (gfc_expr *e)
1802 return gfc_simplify_intconv (e, 2, "INT2");
1807 gfc_simplify_int8 (gfc_expr *e)
1809 return gfc_simplify_intconv (e, 8, "INT8");
1814 gfc_simplify_long (gfc_expr *e)
1816 return gfc_simplify_intconv (e, 4, "LONG");
1821 gfc_simplify_ifix (gfc_expr *e)
1823 gfc_expr *rtrunc, *result;
1825 if (e->expr_type != EXPR_CONSTANT)
1828 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1831 rtrunc = gfc_copy_expr (e);
1833 mpfr_trunc (rtrunc->value.real, e->value.real);
1834 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1836 gfc_free_expr (rtrunc);
1837 return range_check (result, "IFIX");
1842 gfc_simplify_idint (gfc_expr *e)
1844 gfc_expr *rtrunc, *result;
1846 if (e->expr_type != EXPR_CONSTANT)
1849 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1852 rtrunc = gfc_copy_expr (e);
1854 mpfr_trunc (rtrunc->value.real, e->value.real);
1855 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1857 gfc_free_expr (rtrunc);
1858 return range_check (result, "IDINT");
1863 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
1867 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1870 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1872 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1873 return range_check (result, "IOR");
1878 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
1881 int shift, ashift, isize, k, *bits, i;
1883 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1886 if (gfc_extract_int (s, &shift) != NULL)
1888 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
1889 return &gfc_bad_expr;
1892 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
1894 isize = gfc_integer_kinds[k].bit_size;
1903 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
1904 "at %L", &s->where);
1905 return &gfc_bad_expr;
1908 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1912 mpz_set (result->value.integer, e->value.integer);
1913 return range_check (result, "ISHFT");
1916 bits = gfc_getmem (isize * sizeof (int));
1918 for (i = 0; i < isize; i++)
1919 bits[i] = mpz_tstbit (e->value.integer, i);
1923 for (i = 0; i < shift; i++)
1924 mpz_clrbit (result->value.integer, i);
1926 for (i = 0; i < isize - shift; i++)
1929 mpz_clrbit (result->value.integer, i + shift);
1931 mpz_setbit (result->value.integer, i + shift);
1936 for (i = isize - 1; i >= isize - ashift; i--)
1937 mpz_clrbit (result->value.integer, i);
1939 for (i = isize - 1; i >= ashift; i--)
1942 mpz_clrbit (result->value.integer, i - ashift);
1944 mpz_setbit (result->value.integer, i - ashift);
1948 convert_mpz_to_signed (result->value.integer, isize);
1956 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
1959 int shift, ashift, isize, ssize, delta, k;
1962 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1965 if (gfc_extract_int (s, &shift) != NULL)
1967 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
1968 return &gfc_bad_expr;
1971 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1972 isize = gfc_integer_kinds[k].bit_size;
1976 if (sz->expr_type != EXPR_CONSTANT)
1979 if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
1981 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
1982 return &gfc_bad_expr;
1987 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
1988 "BIT_SIZE of first argument at %L", &s->where);
1989 return &gfc_bad_expr;
2003 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2004 "third argument at %L", &s->where);
2006 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2007 "BIT_SIZE of first argument at %L", &s->where);
2008 return &gfc_bad_expr;
2011 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2013 mpz_set (result->value.integer, e->value.integer);
2018 convert_mpz_to_unsigned (result->value.integer, isize);
2020 bits = gfc_getmem (ssize * sizeof (int));
2022 for (i = 0; i < ssize; i++)
2023 bits[i] = mpz_tstbit (e->value.integer, i);
2025 delta = ssize - ashift;
2029 for (i = 0; i < delta; i++)
2032 mpz_clrbit (result->value.integer, i + shift);
2034 mpz_setbit (result->value.integer, i + shift);
2037 for (i = delta; i < ssize; i++)
2040 mpz_clrbit (result->value.integer, i - delta);
2042 mpz_setbit (result->value.integer, i - delta);
2047 for (i = 0; i < ashift; i++)
2050 mpz_clrbit (result->value.integer, i + delta);
2052 mpz_setbit (result->value.integer, i + delta);
2055 for (i = ashift; i < ssize; i++)
2058 mpz_clrbit (result->value.integer, i + shift);
2060 mpz_setbit (result->value.integer, i + shift);
2064 convert_mpz_to_signed (result->value.integer, isize);
2072 gfc_simplify_kind (gfc_expr *e)
2075 if (e->ts.type == BT_DERIVED)
2077 gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
2078 return &gfc_bad_expr;
2081 return gfc_int_expr (e->ts.kind);
2086 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2089 gfc_expr *l, *u, *result;
2092 /* The last dimension of an assumed-size array is special. */
2093 if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2095 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2096 return gfc_copy_expr (as->lower[d-1]);
2101 /* Then, we need to know the extent of the given dimension. */
2105 if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
2108 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2109 gfc_default_integer_kind);
2111 return &gfc_bad_expr;
2113 result = gfc_constant_result (BT_INTEGER, k, &array->where);
2115 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2119 mpz_set_si (result->value.integer, 0);
2121 mpz_set_si (result->value.integer, 1);
2125 /* Nonzero extent. */
2127 mpz_set (result->value.integer, u->value.integer);
2129 mpz_set (result->value.integer, l->value.integer);
2132 return range_check (result, upper ? "UBOUND" : "LBOUND");
2137 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2143 if (array->expr_type != EXPR_VARIABLE)
2146 /* Follow any component references. */
2147 as = array->symtree->n.sym->as;
2148 for (ref = array->ref; ref; ref = ref->next)
2153 switch (ref->u.ar.type)
2160 /* We're done because 'as' has already been set in the
2161 previous iteration. */
2172 as = ref->u.c.component->as;
2184 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2189 /* Multi-dimensional bounds. */
2190 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2192 gfc_constructor *head, *tail;
2195 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2196 if (upper && as->type == AS_ASSUMED_SIZE)
2198 /* An error message will be emitted in
2199 check_assumed_size_reference (resolve.c). */
2200 return &gfc_bad_expr;
2203 /* Simplify the bounds for each dimension. */
2204 for (d = 0; d < array->rank; d++)
2206 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
2207 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2211 for (j = 0; j < d; j++)
2212 gfc_free_expr (bounds[j]);
2217 /* Allocate the result expression. */
2218 e = gfc_get_expr ();
2219 e->where = array->where;
2220 e->expr_type = EXPR_ARRAY;
2221 e->ts.type = BT_INTEGER;
2222 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2223 gfc_default_integer_kind);
2225 return &gfc_bad_expr;
2228 /* The result is a rank 1 array; its size is the rank of the first
2229 argument to {L,U}BOUND. */
2231 e->shape = gfc_get_shape (1);
2232 mpz_init_set_ui (e->shape[0], array->rank);
2234 /* Create the constructor for this array. */
2236 for (d = 0; d < array->rank; d++)
2238 /* Get a new constructor element. */
2240 head = tail = gfc_get_constructor ();
2243 tail->next = gfc_get_constructor ();
2247 tail->where = e->where;
2248 tail->expr = bounds[d];
2250 e->value.constructor = head;
2256 /* A DIM argument is specified. */
2257 if (dim->expr_type != EXPR_CONSTANT)
2260 d = mpz_get_si (dim->value.integer);
2262 if (d < 1 || d > as->rank
2263 || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2265 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2266 return &gfc_bad_expr;
2269 return simplify_bound_dim (array, kind, d, upper, as);
2275 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2277 return simplify_bound (array, dim, kind, 0);
2282 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
2285 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
2288 return &gfc_bad_expr;
2290 if (e->expr_type == EXPR_CONSTANT)
2292 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2293 mpz_set_si (result->value.integer, e->value.character.length);
2294 return range_check (result, "LEN");
2297 if (e->ts.cl != NULL && e->ts.cl->length != NULL
2298 && e->ts.cl->length->expr_type == EXPR_CONSTANT
2299 && e->ts.cl->length->ts.type == BT_INTEGER)
2301 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2302 mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2303 return range_check (result, "LEN");
2311 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
2314 int count, len, lentrim, i;
2315 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
2318 return &gfc_bad_expr;
2320 if (e->expr_type != EXPR_CONSTANT)
2323 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2324 len = e->value.character.length;
2326 for (count = 0, i = 1; i <= len; i++)
2327 if (e->value.character.string[len - i] == ' ')
2332 lentrim = len - count;
2334 mpz_set_si (result->value.integer, lentrim);
2335 return range_check (result, "LEN_TRIM");
2339 gfc_simplify_lgamma (gfc_expr *x __attribute__((unused)))
2341 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
2345 if (x->expr_type != EXPR_CONSTANT)
2348 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2350 gfc_set_model_kind (x->ts.kind);
2352 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
2354 return range_check (result, "LGAMMA");
2362 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
2364 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2367 return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
2372 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
2374 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2377 return gfc_logical_expr (gfc_compare_string (a, b) > 0,
2383 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
2385 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2388 return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
2393 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
2395 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2398 return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
2403 gfc_simplify_log (gfc_expr *x)
2408 if (x->expr_type != EXPR_CONSTANT)
2411 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2413 gfc_set_model_kind (x->ts.kind);
2418 if (mpfr_sgn (x->value.real) <= 0)
2420 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2421 "to zero", &x->where);
2422 gfc_free_expr (result);
2423 return &gfc_bad_expr;
2426 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
2430 if ((mpfr_sgn (x->value.complex.r) == 0)
2431 && (mpfr_sgn (x->value.complex.i) == 0))
2433 gfc_error ("Complex argument of LOG at %L cannot be zero",
2435 gfc_free_expr (result);
2436 return &gfc_bad_expr;
2442 mpfr_atan2 (result->value.complex.i, x->value.complex.i,
2443 x->value.complex.r, GFC_RND_MODE);
2445 mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2446 mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2447 mpfr_add (xr, xr, xi, GFC_RND_MODE);
2448 mpfr_sqrt (xr, xr, GFC_RND_MODE);
2449 mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2457 gfc_internal_error ("gfc_simplify_log: bad type");
2460 return range_check (result, "LOG");
2465 gfc_simplify_log10 (gfc_expr *x)
2469 if (x->expr_type != EXPR_CONSTANT)
2472 gfc_set_model_kind (x->ts.kind);
2474 if (mpfr_sgn (x->value.real) <= 0)
2476 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2477 "to zero", &x->where);
2478 return &gfc_bad_expr;
2481 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2483 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2485 return range_check (result, "LOG10");
2490 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
2495 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2497 return &gfc_bad_expr;
2499 if (e->expr_type != EXPR_CONSTANT)
2502 result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2504 result->value.logical = e->value.logical;
2510 /* This function is special since MAX() can take any number of
2511 arguments. The simplified expression is a rewritten version of the
2512 argument list containing at most one constant element. Other
2513 constant elements are deleted. Because the argument list has
2514 already been checked, this function always succeeds. sign is 1 for
2515 MAX(), -1 for MIN(). */
2518 simplify_min_max (gfc_expr *expr, int sign)
2520 gfc_actual_arglist *arg, *last, *extremum;
2521 gfc_intrinsic_sym * specific;
2525 specific = expr->value.function.isym;
2527 arg = expr->value.function.actual;
2529 for (; arg; last = arg, arg = arg->next)
2531 if (arg->expr->expr_type != EXPR_CONSTANT)
2534 if (extremum == NULL)
2540 switch (arg->expr->ts.type)
2543 if (mpz_cmp (arg->expr->value.integer,
2544 extremum->expr->value.integer) * sign > 0)
2545 mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2549 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
2551 mpfr_max (extremum->expr->value.real, extremum->expr->value.real,
2552 arg->expr->value.real, GFC_RND_MODE);
2554 mpfr_min (extremum->expr->value.real, extremum->expr->value.real,
2555 arg->expr->value.real, GFC_RND_MODE);
2559 #define LENGTH(x) ((x)->expr->value.character.length)
2560 #define STRING(x) ((x)->expr->value.character.string)
2561 if (LENGTH(extremum) < LENGTH(arg))
2563 char * tmp = STRING(extremum);
2565 STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
2566 memcpy (STRING(extremum), tmp, LENGTH(extremum));
2567 memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2568 LENGTH(arg) - LENGTH(extremum));
2569 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
2570 LENGTH(extremum) = LENGTH(arg);
2574 if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
2576 gfc_free (STRING(extremum));
2577 STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
2578 memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
2579 memset (&STRING(extremum)[LENGTH(arg)], ' ',
2580 LENGTH(extremum) - LENGTH(arg));
2581 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
2589 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2592 /* Delete the extra constant argument. */
2594 expr->value.function.actual = arg->next;
2596 last->next = arg->next;
2599 gfc_free_actual_arglist (arg);
2603 /* If there is one value left, replace the function call with the
2605 if (expr->value.function.actual->next != NULL)
2608 /* Convert to the correct type and kind. */
2609 if (expr->ts.type != BT_UNKNOWN)
2610 return gfc_convert_constant (expr->value.function.actual->expr,
2611 expr->ts.type, expr->ts.kind);
2613 if (specific->ts.type != BT_UNKNOWN)
2614 return gfc_convert_constant (expr->value.function.actual->expr,
2615 specific->ts.type, specific->ts.kind);
2617 return gfc_copy_expr (expr->value.function.actual->expr);
2622 gfc_simplify_min (gfc_expr *e)
2624 return simplify_min_max (e, -1);
2629 gfc_simplify_max (gfc_expr *e)
2631 return simplify_min_max (e, 1);
2636 gfc_simplify_maxexponent (gfc_expr *x)
2641 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2643 result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2644 result->where = x->where;
2651 gfc_simplify_minexponent (gfc_expr *x)
2656 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2658 result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2659 result->where = x->where;
2666 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2669 mpfr_t quot, iquot, term;
2672 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2675 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2676 result = gfc_constant_result (a->ts.type, kind, &a->where);
2681 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2683 /* Result is processor-dependent. */
2684 gfc_error ("Second argument MOD at %L is zero", &a->where);
2685 gfc_free_expr (result);
2686 return &gfc_bad_expr;
2688 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2692 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2694 /* Result is processor-dependent. */
2695 gfc_error ("Second argument of MOD at %L is zero", &p->where);
2696 gfc_free_expr (result);
2697 return &gfc_bad_expr;
2700 gfc_set_model_kind (kind);
2705 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2706 mpfr_trunc (iquot, quot);
2707 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2708 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2716 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2719 return range_check (result, "MOD");
2724 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2727 mpfr_t quot, iquot, term;
2730 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2733 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2734 result = gfc_constant_result (a->ts.type, kind, &a->where);
2739 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2741 /* Result is processor-dependent. This processor just opts
2742 to not handle it at all. */
2743 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2744 gfc_free_expr (result);
2745 return &gfc_bad_expr;
2747 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2752 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2754 /* Result is processor-dependent. */
2755 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2756 gfc_free_expr (result);
2757 return &gfc_bad_expr;
2760 gfc_set_model_kind (kind);
2765 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2766 mpfr_floor (iquot, quot);
2767 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2768 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2776 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2779 return range_check (result, "MODULO");
2783 /* Exists for the sole purpose of consistency with other intrinsics. */
2785 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
2786 gfc_expr *fp ATTRIBUTE_UNUSED,
2787 gfc_expr *l ATTRIBUTE_UNUSED,
2788 gfc_expr *to ATTRIBUTE_UNUSED,
2789 gfc_expr *tp ATTRIBUTE_UNUSED)
2796 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
2799 mp_exp_t emin, emax;
2802 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2805 if (mpfr_sgn (s->value.real) == 0)
2807 gfc_error ("Second argument of NEAREST at %L shall not be zero",
2809 return &gfc_bad_expr;
2812 gfc_set_model_kind (x->ts.kind);
2813 result = gfc_copy_expr (x);
2815 /* Save current values of emin and emax. */
2816 emin = mpfr_get_emin ();
2817 emax = mpfr_get_emax ();
2819 /* Set emin and emax for the current model number. */
2820 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
2821 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
2822 mpfr_get_prec(result->value.real) + 1);
2823 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
2825 if (mpfr_sgn (s->value.real) > 0)
2827 mpfr_nextabove (result->value.real);
2828 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
2832 mpfr_nextbelow (result->value.real);
2833 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
2836 mpfr_set_emin (emin);
2837 mpfr_set_emax (emax);
2839 /* Only NaN can occur. Do not use range check as it gives an
2840 error for denormal numbers. */
2841 if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
2843 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
2844 return &gfc_bad_expr;
2852 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
2854 gfc_expr *itrunc, *result;
2857 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2859 return &gfc_bad_expr;
2861 if (e->expr_type != EXPR_CONSTANT)
2864 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2866 itrunc = gfc_copy_expr (e);
2868 mpfr_round (itrunc->value.real, e->value.real);
2870 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
2872 gfc_free_expr (itrunc);
2874 return range_check (result, name);
2879 gfc_simplify_new_line (gfc_expr *e)
2883 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2884 result->value.character.string = gfc_getmem (2);
2885 result->value.character.length = 1;
2886 result->value.character.string[0] = '\n';
2887 result->value.character.string[1] = '\0'; /* For debugger */
2893 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
2895 return simplify_nint ("NINT", e, k);
2900 gfc_simplify_idnint (gfc_expr *e)
2902 return simplify_nint ("IDNINT", e, NULL);
2907 gfc_simplify_not (gfc_expr *e)
2911 if (e->expr_type != EXPR_CONSTANT)
2914 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2916 mpz_com (result->value.integer, e->value.integer);
2918 return range_check (result, "NOT");
2923 gfc_simplify_null (gfc_expr *mold)
2929 result = gfc_get_expr ();
2930 result->ts.type = BT_UNKNOWN;
2933 result = gfc_copy_expr (mold);
2934 result->expr_type = EXPR_NULL;
2941 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
2946 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2949 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2950 if (x->ts.type == BT_INTEGER)
2952 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
2953 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2955 else /* BT_LOGICAL */
2957 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
2958 result->value.logical = x->value.logical || y->value.logical;
2961 return range_check (result, "OR");
2966 gfc_simplify_precision (gfc_expr *e)
2971 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2973 result = gfc_int_expr (gfc_real_kinds[i].precision);
2974 result->where = e->where;
2981 gfc_simplify_radix (gfc_expr *e)
2986 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2990 i = gfc_integer_kinds[i].radix;
2994 i = gfc_real_kinds[i].radix;
3001 result = gfc_int_expr (i);
3002 result->where = e->where;
3009 gfc_simplify_range (gfc_expr *e)
3015 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3020 j = gfc_integer_kinds[i].range;
3025 j = gfc_real_kinds[i].range;
3032 result = gfc_int_expr (j);
3033 result->where = e->where;
3040 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
3045 if (e->ts.type == BT_COMPLEX)
3046 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
3048 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
3051 return &gfc_bad_expr;
3053 if (e->expr_type != EXPR_CONSTANT)
3060 result = gfc_int2real (e, kind);
3064 result = gfc_real2real (e, kind);
3068 result = gfc_complex2real (e, kind);
3072 gfc_internal_error ("bad type in REAL");
3076 if (e->ts.type == BT_INTEGER && e->is_boz)
3082 result = gfc_copy_expr (e);
3083 if (!gfc_convert_boz (result, &ts))
3084 return &gfc_bad_expr;
3086 return range_check (result, "REAL");
3091 gfc_simplify_realpart (gfc_expr *e)
3095 if (e->expr_type != EXPR_CONSTANT)
3098 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3099 mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
3101 return range_check (result, "REALPART");
3105 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
3108 int i, j, len, ncop, nlen;
3110 bool have_length = false;
3112 /* If NCOPIES isn't a constant, there's nothing we can do. */
3113 if (n->expr_type != EXPR_CONSTANT)
3116 /* If NCOPIES is negative, it's an error. */
3117 if (mpz_sgn (n->value.integer) < 0)
3119 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3121 return &gfc_bad_expr;
3124 /* If we don't know the character length, we can do no more. */
3125 if (e->ts.cl && e->ts.cl->length
3126 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
3128 len = mpz_get_si (e->ts.cl->length->value.integer);
3131 else if (e->expr_type == EXPR_CONSTANT
3132 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
3134 len = e->value.character.length;
3139 /* If the source length is 0, any value of NCOPIES is valid
3140 and everything behaves as if NCOPIES == 0. */
3143 mpz_set_ui (ncopies, 0);
3145 mpz_set (ncopies, n->value.integer);
3147 /* Check that NCOPIES isn't too large. */
3153 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
3155 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3159 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
3160 e->ts.cl->length->value.integer);
3164 mpz_init_set_si (mlen, len);
3165 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
3169 /* The check itself. */
3170 if (mpz_cmp (ncopies, max) > 0)
3173 mpz_clear (ncopies);
3174 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3176 return &gfc_bad_expr;
3181 mpz_clear (ncopies);
3183 /* For further simplification, we need the character string to be
3185 if (e->expr_type != EXPR_CONSTANT)
3189 (e->ts.cl->length &&
3190 mpz_sgn (e->ts.cl->length->value.integer)) != 0)
3192 const char *res = gfc_extract_int (n, &ncop);
3193 gcc_assert (res == NULL);
3198 len = e->value.character.length;
3201 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3205 result->value.character.string = gfc_getmem (1);
3206 result->value.character.length = 0;
3207 result->value.character.string[0] = '\0';
3211 result->value.character.length = nlen;
3212 result->value.character.string = gfc_getmem (nlen + 1);
3214 for (i = 0; i < ncop; i++)
3215 for (j = 0; j < len; j++)
3216 result->value.character.string[j + i * len]
3217 = e->value.character.string[j];
3219 result->value.character.string[nlen] = '\0'; /* For debugger */
3224 /* Test that the expression is an constant array. */
3227 is_constant_array_expr (gfc_expr *e)
3234 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
3237 if (e->value.constructor == NULL)
3240 for (c = e->value.constructor; c; c = c->next)
3241 if (c->expr->expr_type != EXPR_CONSTANT)
3248 /* This one is a bear, but mainly has to do with shuffling elements. */
3251 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3252 gfc_expr *pad, gfc_expr *order_exp)
3254 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3255 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3256 gfc_constructor *head, *tail;
3262 /* Check that argument expression types are OK. */
3263 if (!is_constant_array_expr (source))
3266 if (!is_constant_array_expr (shape_exp))
3269 if (!is_constant_array_expr (pad))
3272 if (!is_constant_array_expr (order_exp))
3275 /* Proceed with simplification, unpacking the array. */
3283 e = gfc_get_array_element (shape_exp, rank);
3287 if (gfc_extract_int (e, &shape[rank]) != NULL)
3289 gfc_error ("Integer too large in shape specification at %L",
3297 if (rank >= GFC_MAX_DIMENSIONS)
3299 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3300 "at %L", &e->where);
3305 if (shape[rank] < 0)
3307 gfc_error ("Shape specification at %L cannot be negative",
3317 gfc_error ("Shape specification at %L cannot be the null array",
3322 /* Now unpack the order array if present. */
3323 if (order_exp == NULL)
3325 for (i = 0; i < rank; i++)
3330 for (i = 0; i < rank; i++)
3333 for (i = 0; i < rank; i++)
3335 e = gfc_get_array_element (order_exp, i);
3338 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3339 "size as SHAPE parameter", &order_exp->where);
3343 if (gfc_extract_int (e, &order[i]) != NULL)
3345 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3353 if (order[i] < 1 || order[i] > rank)
3355 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3364 gfc_error ("Invalid permutation in ORDER parameter at %L",
3373 /* Count the elements in the source and padding arrays. */
3378 gfc_array_size (pad, &size);
3379 npad = mpz_get_ui (size);
3383 gfc_array_size (source, &size);
3384 nsource = mpz_get_ui (size);
3387 /* If it weren't for that pesky permutation we could just loop
3388 through the source and round out any shortage with pad elements.
3389 But no, someone just had to have the compiler do something the
3390 user should be doing. */
3392 for (i = 0; i < rank; i++)
3397 /* Figure out which element to extract. */
3398 mpz_set_ui (index, 0);
3400 for (i = rank - 1; i >= 0; i--)
3402 mpz_add_ui (index, index, x[order[i]]);
3404 mpz_mul_ui (index, index, shape[order[i - 1]]);
3407 if (mpz_cmp_ui (index, INT_MAX) > 0)
3408 gfc_internal_error ("Reshaped array too large at %L", &e->where);
3410 j = mpz_get_ui (index);
3413 e = gfc_get_array_element (source, j);
3420 gfc_error ("PAD parameter required for short SOURCE parameter "
3421 "at %L", &source->where);
3426 e = gfc_get_array_element (pad, j);
3430 head = tail = gfc_get_constructor ();
3433 tail->next = gfc_get_constructor ();
3440 tail->where = e->where;
3443 /* Calculate the next element. */
3447 if (++x[i] < shape[i])
3458 e = gfc_get_expr ();
3459 e->where = source->where;
3460 e->expr_type = EXPR_ARRAY;
3461 e->value.constructor = head;
3462 e->shape = gfc_get_shape (rank);
3464 for (i = 0; i < rank; i++)
3465 mpz_init_set_ui (e->shape[i], shape[i]);
3473 gfc_free_constructor (head);
3475 return &gfc_bad_expr;
3480 gfc_simplify_rrspacing (gfc_expr *x)
3486 if (x->expr_type != EXPR_CONSTANT)
3489 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3491 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3493 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3495 /* Special case x = -0 and 0. */
3496 if (mpfr_sgn (result->value.real) == 0)
3498 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3502 /* | x * 2**(-e) | * 2**p. */
3503 e = - (long int) mpfr_get_exp (x->value.real);
3504 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3506 p = (long int) gfc_real_kinds[i].digits;
3507 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3509 return range_check (result, "RRSPACING");
3514 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3516 int k, neg_flag, power, exp_range;
3517 mpfr_t scale, radix;
3520 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3523 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3525 if (mpfr_sgn (x->value.real) == 0)
3527 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3531 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3533 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3535 /* This check filters out values of i that would overflow an int. */
3536 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3537 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3539 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3540 return &gfc_bad_expr;
3543 /* Compute scale = radix ** power. */
3544 power = mpz_get_si (i->value.integer);
3554 gfc_set_model_kind (x->ts.kind);
3557 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3558 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3561 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3563 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3568 return range_check (result, "SCALE");
3573 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
3578 size_t indx, len, lenc;
3579 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3582 return &gfc_bad_expr;
3584 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3587 if (b != NULL && b->value.logical != 0)
3592 result = gfc_constant_result (BT_INTEGER, k, &e->where);
3594 len = e->value.character.length;
3595 lenc = c->value.character.length;
3597 if (len == 0 || lenc == 0)
3605 indx = strcspn (e->value.character.string, c->value.character.string)
3613 for (indx = len; indx > 0; indx--)
3615 for (i = 0; i < lenc; i++)
3617 if (c->value.character.string[i]
3618 == e->value.character.string[indx - 1])
3626 mpz_set_ui (result->value.integer, indx);
3627 return range_check (result, "SCAN");
3632 gfc_simplify_selected_int_kind (gfc_expr *e)
3637 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3642 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3643 if (gfc_integer_kinds[i].range >= range
3644 && gfc_integer_kinds[i].kind < kind)
3645 kind = gfc_integer_kinds[i].kind;
3647 if (kind == INT_MAX)
3650 result = gfc_int_expr (kind);
3651 result->where = e->where;
3658 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3660 int range, precision, i, kind, found_precision, found_range;
3667 if (p->expr_type != EXPR_CONSTANT
3668 || gfc_extract_int (p, &precision) != NULL)
3676 if (q->expr_type != EXPR_CONSTANT
3677 || gfc_extract_int (q, &range) != NULL)
3682 found_precision = 0;
3685 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3687 if (gfc_real_kinds[i].precision >= precision)
3688 found_precision = 1;
3690 if (gfc_real_kinds[i].range >= range)
3693 if (gfc_real_kinds[i].precision >= precision
3694 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3695 kind = gfc_real_kinds[i].kind;
3698 if (kind == INT_MAX)
3702 if (!found_precision)
3708 result = gfc_int_expr (kind);
3709 result->where = (p != NULL) ? p->where : q->where;
3716 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3719 mpfr_t exp, absv, log2, pow2, frac;
3722 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3725 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3727 gfc_set_model_kind (x->ts.kind);
3729 if (mpfr_sgn (x->value.real) == 0)
3731 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3741 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3742 mpfr_log2 (log2, absv, GFC_RND_MODE);
3744 mpfr_trunc (log2, log2);
3745 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3747 /* Old exponent value, and fraction. */
3748 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3750 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3753 exp2 = (unsigned long) mpz_get_d (i->value.integer);
3754 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3761 return range_check (result, "SET_EXPONENT");
3766 gfc_simplify_shape (gfc_expr *source)
3768 mpz_t shape[GFC_MAX_DIMENSIONS];
3769 gfc_expr *result, *e, *f;
3774 if (source->rank == 0)
3775 return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3778 if (source->expr_type != EXPR_VARIABLE)
3781 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3784 ar = gfc_find_array_ref (source);
3786 t = gfc_array_ref_shape (ar, shape);
3788 for (n = 0; n < source->rank; n++)
3790 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3795 mpz_set (e->value.integer, shape[n]);
3796 mpz_clear (shape[n]);
3800 mpz_set_ui (e->value.integer, n + 1);
3802 f = gfc_simplify_size (source, e, NULL);
3806 gfc_free_expr (result);
3815 gfc_append_constructor (result, e);
3823 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3828 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
3831 return &gfc_bad_expr;
3835 if (gfc_array_size (array, &size) == FAILURE)
3840 if (dim->expr_type != EXPR_CONSTANT)
3843 d = mpz_get_ui (dim->value.integer) - 1;
3844 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3848 result = gfc_constant_result (BT_INTEGER, k, &array->where);
3849 mpz_set (result->value.integer, size);
3855 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
3859 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3862 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3867 mpz_abs (result->value.integer, x->value.integer);
3868 if (mpz_sgn (y->value.integer) < 0)
3869 mpz_neg (result->value.integer, result->value.integer);
3874 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3876 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3877 if (mpfr_sgn (y->value.real) < 0)
3878 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3883 gfc_internal_error ("Bad type in gfc_simplify_sign");
3891 gfc_simplify_sin (gfc_expr *x)
3896 if (x->expr_type != EXPR_CONSTANT)
3899 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3904 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3908 gfc_set_model (x->value.real);
3912 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
3913 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3914 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3916 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
3917 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3918 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3925 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3928 return range_check (result, "SIN");
3933 gfc_simplify_sinh (gfc_expr *x)
3937 if (x->expr_type != EXPR_CONSTANT)
3940 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3942 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
3944 return range_check (result, "SINH");
3948 /* The argument is always a double precision real that is converted to
3949 single precision. TODO: Rounding! */
3952 gfc_simplify_sngl (gfc_expr *a)
3956 if (a->expr_type != EXPR_CONSTANT)
3959 result = gfc_real2real (a, gfc_default_real_kind);
3960 return range_check (result, "SNGL");
3965 gfc_simplify_spacing (gfc_expr *x)
3971 if (x->expr_type != EXPR_CONSTANT)
3974 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3976 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3978 /* Special case x = 0 and -0. */
3979 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3980 if (mpfr_sgn (result->value.real) == 0)
3982 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3986 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3987 are the radix, exponent of x, and precision. This excludes the
3988 possibility of subnormal numbers. Fortran 2003 states the result is
3989 b**max(e - p, emin - 1). */
3991 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
3992 en = (long int) gfc_real_kinds[i].min_exponent - 1;
3993 en = en > ep ? en : ep;
3995 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3996 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
3998 return range_check (result, "SPACING");
4003 gfc_simplify_sqrt (gfc_expr *e)
4006 mpfr_t ac, ad, s, t, w;
4008 if (e->expr_type != EXPR_CONSTANT)
4011 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
4016 if (mpfr_cmp_si (e->value.real, 0) < 0)
4018 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
4023 /* Formula taken from Numerical Recipes to avoid over- and
4026 gfc_set_model (e->value.real);
4033 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
4034 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
4036 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
4037 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
4041 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
4042 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
4044 if (mpfr_cmp (ac, ad) >= 0)
4046 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
4047 mpfr_mul (t, t, t, GFC_RND_MODE);
4048 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4049 mpfr_sqrt (t, t, GFC_RND_MODE);
4050 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4051 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4052 mpfr_sqrt (t, t, GFC_RND_MODE);
4053 mpfr_sqrt (s, ac, GFC_RND_MODE);
4054 mpfr_mul (w, s, t, GFC_RND_MODE);
4058 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
4059 mpfr_mul (t, s, s, GFC_RND_MODE);
4060 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4061 mpfr_sqrt (t, t, GFC_RND_MODE);
4062 mpfr_abs (s, s, GFC_RND_MODE);
4063 mpfr_add (t, t, s, GFC_RND_MODE);
4064 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4065 mpfr_sqrt (t, t, GFC_RND_MODE);
4066 mpfr_sqrt (s, ad, GFC_RND_MODE);
4067 mpfr_mul (w, s, t, GFC_RND_MODE);
4070 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
4072 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4073 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
4074 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
4076 else if (mpfr_cmp_ui (w, 0) != 0
4077 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4078 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
4080 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4081 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
4082 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4084 else if (mpfr_cmp_ui (w, 0) != 0
4085 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4086 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
4088 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4089 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
4090 mpfr_neg (w, w, GFC_RND_MODE);
4091 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4094 gfc_internal_error ("invalid complex argument of SQRT at %L",
4106 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
4109 return range_check (result, "SQRT");
4112 gfc_free_expr (result);
4113 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
4114 return &gfc_bad_expr;
4119 gfc_simplify_tan (gfc_expr *x)
4124 if (x->expr_type != EXPR_CONSTANT)
4127 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4129 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4131 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
4133 return range_check (result, "TAN");
4138 gfc_simplify_tanh (gfc_expr *x)
4142 if (x->expr_type != EXPR_CONSTANT)
4145 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4147 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
4149 return range_check (result, "TANH");
4155 gfc_simplify_tiny (gfc_expr *e)
4160 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
4162 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
4163 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4170 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4173 gfc_expr *mold_element;
4176 size_t result_elt_size;
4179 unsigned char *buffer;
4181 if (!gfc_is_constant_expr (source)
4182 || (gfc_init_expr && !gfc_is_constant_expr (mold))
4183 || !gfc_is_constant_expr (size))
4186 if (source->expr_type == EXPR_FUNCTION)
4189 /* Calculate the size of the source. */
4190 if (source->expr_type == EXPR_ARRAY
4191 && gfc_array_size (source, &tmp) == FAILURE)
4192 gfc_internal_error ("Failure getting length of a constant array.");
4194 source_size = gfc_target_expr_size (source);
4196 /* Create an empty new expression with the appropriate characteristics. */
4197 result = gfc_constant_result (mold->ts.type, mold->ts.kind,
4199 result->ts = mold->ts;
4201 mold_element = mold->expr_type == EXPR_ARRAY
4202 ? mold->value.constructor->expr
4205 /* Set result character length, if needed. Note that this needs to be
4206 set even for array expressions, in order to pass this information into
4207 gfc_target_interpret_expr. */
4208 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
4209 result->value.character.length = mold_element->value.character.length;
4211 /* Set the number of elements in the result, and determine its size. */
4212 result_elt_size = gfc_target_expr_size (mold_element);
4213 if (result_elt_size == 0)
4215 gfc_free_expr (result);
4219 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4223 result->expr_type = EXPR_ARRAY;
4227 result_length = (size_t)mpz_get_ui (size->value.integer);
4230 result_length = source_size / result_elt_size;
4231 if (result_length * result_elt_size < source_size)
4235 result->shape = gfc_get_shape (1);
4236 mpz_init_set_ui (result->shape[0], result_length);
4238 result_size = result_length * result_elt_size;
4243 result_size = result_elt_size;
4246 if (gfc_option.warn_surprising && source_size < result_size)
4247 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4248 "source size %ld < result size %ld", &source->where,
4249 (long) source_size, (long) result_size);
4251 /* Allocate the buffer to store the binary version of the source. */
4252 buffer_size = MAX (source_size, result_size);
4253 buffer = (unsigned char*)alloca (buffer_size);
4255 /* Now write source to the buffer. */
4256 gfc_target_encode_expr (source, buffer, buffer_size);
4258 /* And read the buffer back into the new expression. */
4259 gfc_target_interpret_expr (buffer, buffer_size, result);
4266 gfc_simplify_trim (gfc_expr *e)
4269 int count, i, len, lentrim;
4271 if (e->expr_type != EXPR_CONSTANT)
4274 len = e->value.character.length;
4276 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4278 for (count = 0, i = 1; i <= len; ++i)
4280 if (e->value.character.string[len - i] == ' ')
4286 lentrim = len - count;
4288 result->value.character.length = lentrim;
4289 result->value.character.string = gfc_getmem (lentrim + 1);
4291 for (i = 0; i < lentrim; i++)
4292 result->value.character.string[i] = e->value.character.string[i];
4294 result->value.character.string[lentrim] = '\0'; /* For debugger */
4301 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4303 return simplify_bound (array, dim, kind, 1);
4308 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
4312 size_t index, len, lenset;
4314 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
4317 return &gfc_bad_expr;
4319 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4322 if (b != NULL && b->value.logical != 0)
4327 result = gfc_constant_result (BT_INTEGER, k, &s->where);
4329 len = s->value.character.length;
4330 lenset = set->value.character.length;
4334 mpz_set_ui (result->value.integer, 0);
4342 mpz_set_ui (result->value.integer, 1);
4346 index = strspn (s->value.character.string, set->value.character.string)
4356 mpz_set_ui (result->value.integer, len);
4359 for (index = len; index > 0; index --)
4361 for (i = 0; i < lenset; i++)
4363 if (s->value.character.string[index - 1]
4364 == set->value.character.string[i])
4372 mpz_set_ui (result->value.integer, index);
4378 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4383 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4386 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4387 if (x->ts.type == BT_INTEGER)
4389 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4390 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4392 else /* BT_LOGICAL */
4394 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4395 result->value.logical = (x->value.logical && !y->value.logical)
4396 || (!x->value.logical && y->value.logical);
4399 return range_check (result, "XOR");
4403 /****************** Constant simplification *****************/
4405 /* Master function to convert one constant to another. While this is
4406 used as a simplification function, it requires the destination type
4407 and kind information which is supplied by a special case in
4411 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4413 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4414 gfc_constructor *head, *c, *tail = NULL;
4428 f = gfc_int2complex;
4448 f = gfc_real2complex;
4459 f = gfc_complex2int;
4462 f = gfc_complex2real;
4465 f = gfc_complex2complex;
4491 f = gfc_hollerith2int;
4495 f = gfc_hollerith2real;
4499 f = gfc_hollerith2complex;
4503 f = gfc_hollerith2character;
4507 f = gfc_hollerith2logical;
4517 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4522 switch (e->expr_type)
4525 result = f (e, kind);
4527 return &gfc_bad_expr;
4531 if (!gfc_is_constant_expr (e))
4536 for (c = e->value.constructor; c; c = c->next)
4539 head = tail = gfc_get_constructor ();
4542 tail->next = gfc_get_constructor ();
4546 tail->where = c->where;
4548 if (c->iterator == NULL)
4549 tail->expr = f (c->expr, kind);
4552 g = gfc_convert_constant (c->expr, type, kind);
4553 if (g == &gfc_bad_expr)
4558 if (tail->expr == NULL)
4560 gfc_free_constructor (head);
4565 result = gfc_get_expr ();
4566 result->ts.type = type;
4567 result->ts.kind = kind;
4568 result->expr_type = EXPR_ARRAY;
4569 result->value.constructor = head;
4570 result->shape = gfc_copy_shape (e->shape, e->rank);
4571 result->where = e->where;
4572 result->rank = e->rank;