1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
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)");
782 ts.kind = result->ts.kind;
784 if (!gfc_convert_boz (x, &ts))
785 return &gfc_bad_expr;
786 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
792 ts.kind = result->ts.kind;
794 if (!gfc_convert_boz (y, &ts))
795 return &gfc_bad_expr;
796 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
799 return range_check (result, name);
804 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
808 if (x->expr_type != EXPR_CONSTANT
809 || (y != NULL && y->expr_type != EXPR_CONSTANT))
812 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
814 return &gfc_bad_expr;
816 return simplify_cmplx ("CMPLX", x, y, kind);
821 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
825 if (x->expr_type != EXPR_CONSTANT
826 || (y != NULL && y->expr_type != EXPR_CONSTANT))
829 if (x->ts.type == BT_INTEGER)
831 if (y->ts.type == BT_INTEGER)
832 kind = gfc_default_real_kind;
838 if (y->ts.type == BT_REAL)
839 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
844 return simplify_cmplx ("COMPLEX", x, y, kind);
849 gfc_simplify_conjg (gfc_expr *e)
853 if (e->expr_type != EXPR_CONSTANT)
856 result = gfc_copy_expr (e);
857 mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
859 return range_check (result, "CONJG");
864 gfc_simplify_cos (gfc_expr *x)
869 if (x->expr_type != EXPR_CONSTANT)
872 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
877 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
880 gfc_set_model_kind (x->ts.kind);
884 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
885 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
886 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
888 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
889 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
890 mpfr_mul (xp, xp, xq, GFC_RND_MODE);
891 mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
897 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
900 return range_check (result, "COS");
906 gfc_simplify_cosh (gfc_expr *x)
910 if (x->expr_type != EXPR_CONSTANT)
913 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
915 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
917 return range_check (result, "COSH");
922 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
925 if (x->expr_type != EXPR_CONSTANT
926 || (y != NULL && y->expr_type != EXPR_CONSTANT))
929 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
934 gfc_simplify_dble (gfc_expr *e)
938 if (e->expr_type != EXPR_CONSTANT)
945 result = gfc_int2real (e, gfc_default_double_kind);
949 result = gfc_real2real (e, gfc_default_double_kind);
953 result = gfc_complex2real (e, gfc_default_double_kind);
957 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
960 if (e->ts.type == BT_INTEGER && e->is_boz)
964 ts.kind = gfc_default_double_kind;
965 result = gfc_copy_expr (e);
966 if (!gfc_convert_boz (result, &ts))
967 return &gfc_bad_expr;
970 return range_check (result, "DBLE");
975 gfc_simplify_digits (gfc_expr *x)
979 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
983 digits = gfc_integer_kinds[i].digits;
988 digits = gfc_real_kinds[i].digits;
995 return gfc_int_expr (digits);
1000 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1005 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1008 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1009 result = gfc_constant_result (x->ts.type, kind, &x->where);
1014 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1015 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1017 mpz_set_ui (result->value.integer, 0);
1022 if (mpfr_cmp (x->value.real, y->value.real) > 0)
1023 mpfr_sub (result->value.real, x->value.real, y->value.real,
1026 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1031 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1034 return range_check (result, "DIM");
1039 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1041 gfc_expr *a1, *a2, *result;
1043 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1046 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1048 a1 = gfc_real2real (x, gfc_default_double_kind);
1049 a2 = gfc_real2real (y, gfc_default_double_kind);
1051 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1056 return range_check (result, "DPROD");
1061 gfc_simplify_epsilon (gfc_expr *e)
1066 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1068 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1070 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1072 return range_check (result, "EPSILON");
1077 gfc_simplify_exp (gfc_expr *x)
1082 if (x->expr_type != EXPR_CONSTANT)
1085 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1090 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1094 gfc_set_model_kind (x->ts.kind);
1097 mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1098 mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1099 mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1100 mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1101 mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1107 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1110 return range_check (result, "EXP");
1114 gfc_simplify_exponent (gfc_expr *x)
1119 if (x->expr_type != EXPR_CONSTANT)
1122 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1125 gfc_set_model (x->value.real);
1127 if (mpfr_sgn (x->value.real) == 0)
1129 mpz_set_ui (result->value.integer, 0);
1133 i = (int) mpfr_get_exp (x->value.real);
1134 mpz_set_si (result->value.integer, i);
1136 return range_check (result, "EXPONENT");
1141 gfc_simplify_float (gfc_expr *a)
1145 if (a->expr_type != EXPR_CONSTANT)
1153 ts.kind = gfc_default_real_kind;
1155 result = gfc_copy_expr (a);
1156 if (!gfc_convert_boz (result, &ts))
1157 return &gfc_bad_expr;
1160 result = gfc_int2real (a, gfc_default_real_kind);
1161 return range_check (result, "FLOAT");
1166 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1172 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1174 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1176 if (e->expr_type != EXPR_CONSTANT)
1179 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1181 gfc_set_model_kind (kind);
1183 mpfr_floor (floor, e->value.real);
1185 gfc_mpfr_to_mpz (result->value.integer, floor);
1189 return range_check (result, "FLOOR");
1194 gfc_simplify_fraction (gfc_expr *x)
1197 mpfr_t absv, exp, pow2;
1199 if (x->expr_type != EXPR_CONSTANT)
1202 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1204 gfc_set_model_kind (x->ts.kind);
1206 if (mpfr_sgn (x->value.real) == 0)
1208 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1216 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1217 mpfr_log2 (exp, absv, GFC_RND_MODE);
1219 mpfr_trunc (exp, exp);
1220 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1222 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1224 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1230 return range_check (result, "FRACTION");
1235 gfc_simplify_gamma (gfc_expr *x)
1239 if (x->expr_type != EXPR_CONSTANT)
1242 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1244 gfc_set_model_kind (x->ts.kind);
1246 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1248 return range_check (result, "GAMMA");
1253 gfc_simplify_huge (gfc_expr *e)
1258 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1260 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1265 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1269 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1279 /* We use the processor's collating sequence, because all
1280 systems that gfortran currently works on are ASCII. */
1283 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
1288 if (e->expr_type != EXPR_CONSTANT)
1291 if (e->value.character.length != 1)
1293 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1294 return &gfc_bad_expr;
1297 index = (unsigned char) e->value.character.string[0];
1299 if (gfc_option.warn_surprising && index > 127)
1300 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1303 if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
1304 return &gfc_bad_expr;
1306 result->where = e->where;
1308 return range_check (result, "IACHAR");
1313 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1317 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1320 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1322 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1324 return range_check (result, "IAND");
1329 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1334 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1337 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1339 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1340 return &gfc_bad_expr;
1343 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1345 if (pos >= gfc_integer_kinds[k].bit_size)
1347 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1349 return &gfc_bad_expr;
1352 result = gfc_copy_expr (x);
1354 convert_mpz_to_unsigned (result->value.integer,
1355 gfc_integer_kinds[k].bit_size);
1357 mpz_clrbit (result->value.integer, pos);
1359 convert_mpz_to_signed (result->value.integer,
1360 gfc_integer_kinds[k].bit_size);
1362 return range_check (result, "IBCLR");
1367 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1374 if (x->expr_type != EXPR_CONSTANT
1375 || y->expr_type != EXPR_CONSTANT
1376 || z->expr_type != EXPR_CONSTANT)
1379 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1381 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1382 return &gfc_bad_expr;
1385 if (gfc_extract_int (z, &len) != NULL || len < 0)
1387 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1388 return &gfc_bad_expr;
1391 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1393 bitsize = gfc_integer_kinds[k].bit_size;
1395 if (pos + len > bitsize)
1397 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1398 "bit size at %L", &y->where);
1399 return &gfc_bad_expr;
1402 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1404 bits = gfc_getmem (bitsize * sizeof (int));
1406 for (i = 0; i < bitsize; i++)
1409 for (i = 0; i < len; i++)
1410 bits[i] = mpz_tstbit (x->value.integer, i + pos);
1412 for (i = 0; i < bitsize; i++)
1415 mpz_clrbit (result->value.integer, i);
1416 else if (bits[i] == 1)
1417 mpz_setbit (result->value.integer, i);
1419 gfc_internal_error ("IBITS: Bad bit");
1424 return range_check (result, "IBITS");
1429 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1434 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1437 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1439 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1440 return &gfc_bad_expr;
1443 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1445 if (pos >= gfc_integer_kinds[k].bit_size)
1447 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1449 return &gfc_bad_expr;
1452 result = gfc_copy_expr (x);
1454 convert_mpz_to_unsigned (result->value.integer,
1455 gfc_integer_kinds[k].bit_size);
1457 mpz_setbit (result->value.integer, pos);
1459 convert_mpz_to_signed (result->value.integer,
1460 gfc_integer_kinds[k].bit_size);
1462 return range_check (result, "IBSET");
1467 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
1472 if (e->expr_type != EXPR_CONSTANT)
1475 if (e->value.character.length != 1)
1477 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1478 return &gfc_bad_expr;
1481 index = (unsigned char) e->value.character.string[0];
1483 if (index < 0 || index > UCHAR_MAX)
1484 gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
1486 if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
1487 return &gfc_bad_expr;
1489 result->where = e->where;
1490 return range_check (result, "ICHAR");
1495 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
1499 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1502 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1504 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1506 return range_check (result, "IEOR");
1511 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
1514 int back, len, lensub;
1515 int i, j, k, count, index = 0, start;
1517 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1520 if (b != NULL && b->value.logical != 0)
1525 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
1527 return &gfc_bad_expr;
1529 result = gfc_constant_result (BT_INTEGER, k, &x->where);
1531 len = x->value.character.length;
1532 lensub = y->value.character.length;
1536 mpz_set_si (result->value.integer, 0);
1544 mpz_set_si (result->value.integer, 1);
1547 else if (lensub == 1)
1549 for (i = 0; i < len; i++)
1551 for (j = 0; j < lensub; j++)
1553 if (y->value.character.string[j]
1554 == x->value.character.string[i])
1564 for (i = 0; i < len; i++)
1566 for (j = 0; j < lensub; j++)
1568 if (y->value.character.string[j]
1569 == x->value.character.string[i])
1574 for (k = 0; k < lensub; k++)
1576 if (y->value.character.string[k]
1577 == x->value.character.string[k + start])
1581 if (count == lensub)
1596 mpz_set_si (result->value.integer, len + 1);
1599 else if (lensub == 1)
1601 for (i = 0; i < len; i++)
1603 for (j = 0; j < lensub; j++)
1605 if (y->value.character.string[j]
1606 == x->value.character.string[len - i])
1608 index = len - i + 1;
1616 for (i = 0; i < len; i++)
1618 for (j = 0; j < lensub; j++)
1620 if (y->value.character.string[j]
1621 == x->value.character.string[len - i])
1624 if (start <= len - lensub)
1627 for (k = 0; k < lensub; k++)
1628 if (y->value.character.string[k]
1629 == x->value.character.string[k + start])
1632 if (count == lensub)
1649 mpz_set_si (result->value.integer, index);
1650 return range_check (result, "INDEX");
1655 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
1657 gfc_expr *rpart, *rtrunc, *result;
1660 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1662 return &gfc_bad_expr;
1664 if (e->expr_type != EXPR_CONSTANT)
1667 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1672 mpz_set (result->value.integer, e->value.integer);
1676 rtrunc = gfc_copy_expr (e);
1677 mpfr_trunc (rtrunc->value.real, e->value.real);
1678 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1679 gfc_free_expr (rtrunc);
1683 rpart = gfc_complex2real (e, kind);
1684 rtrunc = gfc_copy_expr (rpart);
1685 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1686 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1687 gfc_free_expr (rpart);
1688 gfc_free_expr (rtrunc);
1692 gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1693 gfc_free_expr (result);
1694 return &gfc_bad_expr;
1697 return range_check (result, "INT");
1702 gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
1704 gfc_expr *rpart, *rtrunc, *result;
1706 if (e->expr_type != EXPR_CONSTANT)
1709 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1714 mpz_set (result->value.integer, e->value.integer);
1718 rtrunc = gfc_copy_expr (e);
1719 mpfr_trunc (rtrunc->value.real, e->value.real);
1720 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1721 gfc_free_expr (rtrunc);
1725 rpart = gfc_complex2real (e, kind);
1726 rtrunc = gfc_copy_expr (rpart);
1727 mpfr_trunc (rtrunc->value.real, rpart->value.real);
1728 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1729 gfc_free_expr (rpart);
1730 gfc_free_expr (rtrunc);
1734 gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
1735 gfc_free_expr (result);
1736 return &gfc_bad_expr;
1739 return range_check (result, name);
1744 gfc_simplify_int2 (gfc_expr *e)
1746 return gfc_simplify_intconv (e, 2, "INT2");
1751 gfc_simplify_int8 (gfc_expr *e)
1753 return gfc_simplify_intconv (e, 8, "INT8");
1758 gfc_simplify_long (gfc_expr *e)
1760 return gfc_simplify_intconv (e, 4, "LONG");
1765 gfc_simplify_ifix (gfc_expr *e)
1767 gfc_expr *rtrunc, *result;
1769 if (e->expr_type != EXPR_CONSTANT)
1772 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1775 rtrunc = gfc_copy_expr (e);
1777 mpfr_trunc (rtrunc->value.real, e->value.real);
1778 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1780 gfc_free_expr (rtrunc);
1781 return range_check (result, "IFIX");
1786 gfc_simplify_idint (gfc_expr *e)
1788 gfc_expr *rtrunc, *result;
1790 if (e->expr_type != EXPR_CONSTANT)
1793 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1796 rtrunc = gfc_copy_expr (e);
1798 mpfr_trunc (rtrunc->value.real, e->value.real);
1799 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1801 gfc_free_expr (rtrunc);
1802 return range_check (result, "IDINT");
1807 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
1811 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1814 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1816 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1817 return range_check (result, "IOR");
1822 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
1825 int shift, ashift, isize, k, *bits, i;
1827 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1830 if (gfc_extract_int (s, &shift) != NULL)
1832 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
1833 return &gfc_bad_expr;
1836 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
1838 isize = gfc_integer_kinds[k].bit_size;
1847 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
1848 "at %L", &s->where);
1849 return &gfc_bad_expr;
1852 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1856 mpz_set (result->value.integer, e->value.integer);
1857 return range_check (result, "ISHFT");
1860 bits = gfc_getmem (isize * sizeof (int));
1862 for (i = 0; i < isize; i++)
1863 bits[i] = mpz_tstbit (e->value.integer, i);
1867 for (i = 0; i < shift; i++)
1868 mpz_clrbit (result->value.integer, i);
1870 for (i = 0; i < isize - shift; i++)
1873 mpz_clrbit (result->value.integer, i + shift);
1875 mpz_setbit (result->value.integer, i + shift);
1880 for (i = isize - 1; i >= isize - ashift; i--)
1881 mpz_clrbit (result->value.integer, i);
1883 for (i = isize - 1; i >= ashift; i--)
1886 mpz_clrbit (result->value.integer, i - ashift);
1888 mpz_setbit (result->value.integer, i - ashift);
1892 convert_mpz_to_signed (result->value.integer, isize);
1900 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
1903 int shift, ashift, isize, ssize, delta, k;
1906 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
1909 if (gfc_extract_int (s, &shift) != NULL)
1911 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
1912 return &gfc_bad_expr;
1915 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1916 isize = gfc_integer_kinds[k].bit_size;
1920 if (sz->expr_type != EXPR_CONSTANT)
1923 if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
1925 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
1926 return &gfc_bad_expr;
1931 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
1932 "BIT_SIZE of first argument at %L", &s->where);
1933 return &gfc_bad_expr;
1947 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1948 "third argument at %L", &s->where);
1950 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
1951 "BIT_SIZE of first argument at %L", &s->where);
1952 return &gfc_bad_expr;
1955 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1957 mpz_set (result->value.integer, e->value.integer);
1962 convert_mpz_to_unsigned (result->value.integer, isize);
1964 bits = gfc_getmem (ssize * sizeof (int));
1966 for (i = 0; i < ssize; i++)
1967 bits[i] = mpz_tstbit (e->value.integer, i);
1969 delta = ssize - ashift;
1973 for (i = 0; i < delta; i++)
1976 mpz_clrbit (result->value.integer, i + shift);
1978 mpz_setbit (result->value.integer, i + shift);
1981 for (i = delta; i < ssize; i++)
1984 mpz_clrbit (result->value.integer, i - delta);
1986 mpz_setbit (result->value.integer, i - delta);
1991 for (i = 0; i < ashift; i++)
1994 mpz_clrbit (result->value.integer, i + delta);
1996 mpz_setbit (result->value.integer, i + delta);
1999 for (i = ashift; i < ssize; i++)
2002 mpz_clrbit (result->value.integer, i + shift);
2004 mpz_setbit (result->value.integer, i + shift);
2008 convert_mpz_to_signed (result->value.integer, isize);
2016 gfc_simplify_kind (gfc_expr *e)
2019 if (e->ts.type == BT_DERIVED)
2021 gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
2022 return &gfc_bad_expr;
2025 return gfc_int_expr (e->ts.kind);
2030 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2033 gfc_expr *l, *u, *result;
2036 /* The last dimension of an assumed-size array is special. */
2037 if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2039 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2040 return gfc_copy_expr (as->lower[d-1]);
2045 /* Then, we need to know the extent of the given dimension. */
2049 if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
2052 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2053 gfc_default_integer_kind);
2055 return &gfc_bad_expr;
2057 result = gfc_constant_result (BT_INTEGER, k, &array->where);
2059 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2063 mpz_set_si (result->value.integer, 0);
2065 mpz_set_si (result->value.integer, 1);
2069 /* Nonzero extent. */
2071 mpz_set (result->value.integer, u->value.integer);
2073 mpz_set (result->value.integer, l->value.integer);
2076 return range_check (result, upper ? "UBOUND" : "LBOUND");
2081 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2087 if (array->expr_type != EXPR_VARIABLE)
2090 /* Follow any component references. */
2091 as = array->symtree->n.sym->as;
2092 for (ref = array->ref; ref; ref = ref->next)
2097 switch (ref->u.ar.type)
2104 /* We're done because 'as' has already been set in the
2105 previous iteration. */
2116 as = ref->u.c.component->as;
2128 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2133 /* Multi-dimensional bounds. */
2134 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2136 gfc_constructor *head, *tail;
2139 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2140 if (upper && as->type == AS_ASSUMED_SIZE)
2142 /* An error message will be emitted in
2143 check_assumed_size_reference (resolve.c). */
2144 return &gfc_bad_expr;
2147 /* Simplify the bounds for each dimension. */
2148 for (d = 0; d < array->rank; d++)
2150 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
2151 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2155 for (j = 0; j < d; j++)
2156 gfc_free_expr (bounds[j]);
2161 /* Allocate the result expression. */
2162 e = gfc_get_expr ();
2163 e->where = array->where;
2164 e->expr_type = EXPR_ARRAY;
2165 e->ts.type = BT_INTEGER;
2166 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2167 gfc_default_integer_kind);
2169 return &gfc_bad_expr;
2172 /* The result is a rank 1 array; its size is the rank of the first
2173 argument to {L,U}BOUND. */
2175 e->shape = gfc_get_shape (1);
2176 mpz_init_set_ui (e->shape[0], array->rank);
2178 /* Create the constructor for this array. */
2180 for (d = 0; d < array->rank; d++)
2182 /* Get a new constructor element. */
2184 head = tail = gfc_get_constructor ();
2187 tail->next = gfc_get_constructor ();
2191 tail->where = e->where;
2192 tail->expr = bounds[d];
2194 e->value.constructor = head;
2200 /* A DIM argument is specified. */
2201 if (dim->expr_type != EXPR_CONSTANT)
2204 d = mpz_get_si (dim->value.integer);
2206 if (d < 1 || d > as->rank
2207 || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2209 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2210 return &gfc_bad_expr;
2213 return simplify_bound_dim (array, kind, d, upper, as);
2219 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2221 return simplify_bound (array, dim, kind, 0);
2226 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
2229 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
2232 return &gfc_bad_expr;
2234 if (e->expr_type == EXPR_CONSTANT)
2236 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2237 mpz_set_si (result->value.integer, e->value.character.length);
2238 return range_check (result, "LEN");
2241 if (e->ts.cl != NULL && e->ts.cl->length != NULL
2242 && e->ts.cl->length->expr_type == EXPR_CONSTANT
2243 && e->ts.cl->length->ts.type == BT_INTEGER)
2245 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2246 mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2247 return range_check (result, "LEN");
2255 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
2258 int count, len, lentrim, i;
2259 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
2262 return &gfc_bad_expr;
2264 if (e->expr_type != EXPR_CONSTANT)
2267 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2268 len = e->value.character.length;
2270 for (count = 0, i = 1; i <= len; i++)
2271 if (e->value.character.string[len - i] == ' ')
2276 lentrim = len - count;
2278 mpz_set_si (result->value.integer, lentrim);
2279 return range_check (result, "LEN_TRIM");
2283 gfc_simplify_lgamma (gfc_expr *x __attribute__((unused)))
2285 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
2289 if (x->expr_type != EXPR_CONSTANT)
2292 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2294 gfc_set_model_kind (x->ts.kind);
2296 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
2298 return range_check (result, "LGAMMA");
2306 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
2308 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2311 return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
2316 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
2318 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2321 return gfc_logical_expr (gfc_compare_string (a, b) > 0,
2327 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
2329 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2332 return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
2337 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
2339 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2342 return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
2347 gfc_simplify_log (gfc_expr *x)
2352 if (x->expr_type != EXPR_CONSTANT)
2355 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2357 gfc_set_model_kind (x->ts.kind);
2362 if (mpfr_sgn (x->value.real) <= 0)
2364 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2365 "to zero", &x->where);
2366 gfc_free_expr (result);
2367 return &gfc_bad_expr;
2370 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
2374 if ((mpfr_sgn (x->value.complex.r) == 0)
2375 && (mpfr_sgn (x->value.complex.i) == 0))
2377 gfc_error ("Complex argument of LOG at %L cannot be zero",
2379 gfc_free_expr (result);
2380 return &gfc_bad_expr;
2386 mpfr_atan2 (result->value.complex.i, x->value.complex.i,
2387 x->value.complex.r, GFC_RND_MODE);
2389 mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2390 mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2391 mpfr_add (xr, xr, xi, GFC_RND_MODE);
2392 mpfr_sqrt (xr, xr, GFC_RND_MODE);
2393 mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2401 gfc_internal_error ("gfc_simplify_log: bad type");
2404 return range_check (result, "LOG");
2409 gfc_simplify_log10 (gfc_expr *x)
2413 if (x->expr_type != EXPR_CONSTANT)
2416 gfc_set_model_kind (x->ts.kind);
2418 if (mpfr_sgn (x->value.real) <= 0)
2420 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2421 "to zero", &x->where);
2422 return &gfc_bad_expr;
2425 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2427 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2429 return range_check (result, "LOG10");
2434 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
2439 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2441 return &gfc_bad_expr;
2443 if (e->expr_type != EXPR_CONSTANT)
2446 result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2448 result->value.logical = e->value.logical;
2454 /* This function is special since MAX() can take any number of
2455 arguments. The simplified expression is a rewritten version of the
2456 argument list containing at most one constant element. Other
2457 constant elements are deleted. Because the argument list has
2458 already been checked, this function always succeeds. sign is 1 for
2459 MAX(), -1 for MIN(). */
2462 simplify_min_max (gfc_expr *expr, int sign)
2464 gfc_actual_arglist *arg, *last, *extremum;
2465 gfc_intrinsic_sym * specific;
2469 specific = expr->value.function.isym;
2471 arg = expr->value.function.actual;
2473 for (; arg; last = arg, arg = arg->next)
2475 if (arg->expr->expr_type != EXPR_CONSTANT)
2478 if (extremum == NULL)
2484 switch (arg->expr->ts.type)
2487 if (mpz_cmp (arg->expr->value.integer,
2488 extremum->expr->value.integer) * sign > 0)
2489 mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2493 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
2495 mpfr_max (extremum->expr->value.real, extremum->expr->value.real,
2496 arg->expr->value.real, GFC_RND_MODE);
2498 mpfr_min (extremum->expr->value.real, extremum->expr->value.real,
2499 arg->expr->value.real, GFC_RND_MODE);
2503 #define LENGTH(x) ((x)->expr->value.character.length)
2504 #define STRING(x) ((x)->expr->value.character.string)
2505 if (LENGTH(extremum) < LENGTH(arg))
2507 char * tmp = STRING(extremum);
2509 STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
2510 memcpy (STRING(extremum), tmp, LENGTH(extremum));
2511 memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2512 LENGTH(arg) - LENGTH(extremum));
2513 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
2514 LENGTH(extremum) = LENGTH(arg);
2518 if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
2520 gfc_free (STRING(extremum));
2521 STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
2522 memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
2523 memset (&STRING(extremum)[LENGTH(arg)], ' ',
2524 LENGTH(extremum) - LENGTH(arg));
2525 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
2533 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2536 /* Delete the extra constant argument. */
2538 expr->value.function.actual = arg->next;
2540 last->next = arg->next;
2543 gfc_free_actual_arglist (arg);
2547 /* If there is one value left, replace the function call with the
2549 if (expr->value.function.actual->next != NULL)
2552 /* Convert to the correct type and kind. */
2553 if (expr->ts.type != BT_UNKNOWN)
2554 return gfc_convert_constant (expr->value.function.actual->expr,
2555 expr->ts.type, expr->ts.kind);
2557 if (specific->ts.type != BT_UNKNOWN)
2558 return gfc_convert_constant (expr->value.function.actual->expr,
2559 specific->ts.type, specific->ts.kind);
2561 return gfc_copy_expr (expr->value.function.actual->expr);
2566 gfc_simplify_min (gfc_expr *e)
2568 return simplify_min_max (e, -1);
2573 gfc_simplify_max (gfc_expr *e)
2575 return simplify_min_max (e, 1);
2580 gfc_simplify_maxexponent (gfc_expr *x)
2585 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2587 result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2588 result->where = x->where;
2595 gfc_simplify_minexponent (gfc_expr *x)
2600 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2602 result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2603 result->where = x->where;
2610 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2613 mpfr_t quot, iquot, term;
2616 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2619 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2620 result = gfc_constant_result (a->ts.type, kind, &a->where);
2625 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2627 /* Result is processor-dependent. */
2628 gfc_error ("Second argument MOD at %L is zero", &a->where);
2629 gfc_free_expr (result);
2630 return &gfc_bad_expr;
2632 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2636 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2638 /* Result is processor-dependent. */
2639 gfc_error ("Second argument of MOD at %L is zero", &p->where);
2640 gfc_free_expr (result);
2641 return &gfc_bad_expr;
2644 gfc_set_model_kind (kind);
2649 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2650 mpfr_trunc (iquot, quot);
2651 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2652 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2660 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2663 return range_check (result, "MOD");
2668 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2671 mpfr_t quot, iquot, term;
2674 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2677 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2678 result = gfc_constant_result (a->ts.type, kind, &a->where);
2683 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2685 /* Result is processor-dependent. This processor just opts
2686 to not handle it at all. */
2687 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2688 gfc_free_expr (result);
2689 return &gfc_bad_expr;
2691 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2696 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2698 /* Result is processor-dependent. */
2699 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2700 gfc_free_expr (result);
2701 return &gfc_bad_expr;
2704 gfc_set_model_kind (kind);
2709 mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
2710 mpfr_floor (iquot, quot);
2711 mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
2712 mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
2720 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2723 return range_check (result, "MODULO");
2727 /* Exists for the sole purpose of consistency with other intrinsics. */
2729 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
2730 gfc_expr *fp ATTRIBUTE_UNUSED,
2731 gfc_expr *l ATTRIBUTE_UNUSED,
2732 gfc_expr *to ATTRIBUTE_UNUSED,
2733 gfc_expr *tp ATTRIBUTE_UNUSED)
2740 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
2743 mp_exp_t emin, emax;
2746 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2749 if (mpfr_sgn (s->value.real) == 0)
2751 gfc_error ("Second argument of NEAREST at %L shall not be zero",
2753 return &gfc_bad_expr;
2756 gfc_set_model_kind (x->ts.kind);
2757 result = gfc_copy_expr (x);
2759 /* Save current values of emin and emax. */
2760 emin = mpfr_get_emin ();
2761 emax = mpfr_get_emax ();
2763 /* Set emin and emax for the current model number. */
2764 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
2765 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
2766 mpfr_get_prec(result->value.real) + 1);
2767 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
2769 if (mpfr_sgn (s->value.real) > 0)
2771 mpfr_nextabove (result->value.real);
2772 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
2776 mpfr_nextbelow (result->value.real);
2777 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
2780 mpfr_set_emin (emin);
2781 mpfr_set_emax (emax);
2783 /* Only NaN can occur. Do not use range check as it gives an
2784 error for denormal numbers. */
2785 if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
2787 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
2788 return &gfc_bad_expr;
2796 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
2798 gfc_expr *itrunc, *result;
2801 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2803 return &gfc_bad_expr;
2805 if (e->expr_type != EXPR_CONSTANT)
2808 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2810 itrunc = gfc_copy_expr (e);
2812 mpfr_round (itrunc->value.real, e->value.real);
2814 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
2816 gfc_free_expr (itrunc);
2818 return range_check (result, name);
2823 gfc_simplify_new_line (gfc_expr *e)
2827 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2828 result->value.character.string = gfc_getmem (2);
2829 result->value.character.length = 1;
2830 result->value.character.string[0] = '\n';
2831 result->value.character.string[1] = '\0'; /* For debugger */
2837 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
2839 return simplify_nint ("NINT", e, k);
2844 gfc_simplify_idnint (gfc_expr *e)
2846 return simplify_nint ("IDNINT", e, NULL);
2851 gfc_simplify_not (gfc_expr *e)
2855 if (e->expr_type != EXPR_CONSTANT)
2858 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2860 mpz_com (result->value.integer, e->value.integer);
2862 return range_check (result, "NOT");
2867 gfc_simplify_null (gfc_expr *mold)
2873 result = gfc_get_expr ();
2874 result->ts.type = BT_UNKNOWN;
2877 result = gfc_copy_expr (mold);
2878 result->expr_type = EXPR_NULL;
2885 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
2890 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2893 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2894 if (x->ts.type == BT_INTEGER)
2896 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
2897 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2899 else /* BT_LOGICAL */
2901 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
2902 result->value.logical = x->value.logical || y->value.logical;
2905 return range_check (result, "OR");
2910 gfc_simplify_precision (gfc_expr *e)
2915 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2917 result = gfc_int_expr (gfc_real_kinds[i].precision);
2918 result->where = e->where;
2925 gfc_simplify_radix (gfc_expr *e)
2930 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2934 i = gfc_integer_kinds[i].radix;
2938 i = gfc_real_kinds[i].radix;
2945 result = gfc_int_expr (i);
2946 result->where = e->where;
2953 gfc_simplify_range (gfc_expr *e)
2959 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2964 j = gfc_integer_kinds[i].range;
2969 j = gfc_real_kinds[i].range;
2976 result = gfc_int_expr (j);
2977 result->where = e->where;
2984 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
2989 if (e->ts.type == BT_COMPLEX)
2990 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
2992 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
2995 return &gfc_bad_expr;
2997 if (e->expr_type != EXPR_CONSTANT)
3004 result = gfc_int2real (e, kind);
3008 result = gfc_real2real (e, kind);
3012 result = gfc_complex2real (e, kind);
3016 gfc_internal_error ("bad type in REAL");
3020 if (e->ts.type == BT_INTEGER && e->is_boz)
3025 result = gfc_copy_expr (e);
3026 if (!gfc_convert_boz (result, &ts))
3027 return &gfc_bad_expr;
3029 return range_check (result, "REAL");
3034 gfc_simplify_realpart (gfc_expr *e)
3038 if (e->expr_type != EXPR_CONSTANT)
3041 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3042 mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
3044 return range_check (result, "REALPART");
3048 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
3051 int i, j, len, ncop, nlen;
3053 bool have_length = false;
3055 /* If NCOPIES isn't a constant, there's nothing we can do. */
3056 if (n->expr_type != EXPR_CONSTANT)
3059 /* If NCOPIES is negative, it's an error. */
3060 if (mpz_sgn (n->value.integer) < 0)
3062 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3064 return &gfc_bad_expr;
3067 /* If we don't know the character length, we can do no more. */
3068 if (e->ts.cl && e->ts.cl->length
3069 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
3071 len = mpz_get_si (e->ts.cl->length->value.integer);
3074 else if (e->expr_type == EXPR_CONSTANT
3075 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
3077 len = e->value.character.length;
3082 /* If the source length is 0, any value of NCOPIES is valid
3083 and everything behaves as if NCOPIES == 0. */
3086 mpz_set_ui (ncopies, 0);
3088 mpz_set (ncopies, n->value.integer);
3090 /* Check that NCOPIES isn't too large. */
3096 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
3098 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3102 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
3103 e->ts.cl->length->value.integer);
3107 mpz_init_set_si (mlen, len);
3108 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
3112 /* The check itself. */
3113 if (mpz_cmp (ncopies, max) > 0)
3116 mpz_clear (ncopies);
3117 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3119 return &gfc_bad_expr;
3124 mpz_clear (ncopies);
3126 /* For further simplification, we need the character string to be
3128 if (e->expr_type != EXPR_CONSTANT)
3132 (e->ts.cl->length &&
3133 mpz_sgn (e->ts.cl->length->value.integer)) != 0)
3135 const char *res = gfc_extract_int (n, &ncop);
3136 gcc_assert (res == NULL);
3141 len = e->value.character.length;
3144 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3148 result->value.character.string = gfc_getmem (1);
3149 result->value.character.length = 0;
3150 result->value.character.string[0] = '\0';
3154 result->value.character.length = nlen;
3155 result->value.character.string = gfc_getmem (nlen + 1);
3157 for (i = 0; i < ncop; i++)
3158 for (j = 0; j < len; j++)
3159 result->value.character.string[j + i * len]
3160 = e->value.character.string[j];
3162 result->value.character.string[nlen] = '\0'; /* For debugger */
3167 /* Test that the expression is an constant array. */
3170 is_constant_array_expr (gfc_expr *e)
3177 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
3180 if (e->value.constructor == NULL)
3183 for (c = e->value.constructor; c; c = c->next)
3184 if (c->expr->expr_type != EXPR_CONSTANT)
3191 /* This one is a bear, but mainly has to do with shuffling elements. */
3194 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3195 gfc_expr *pad, gfc_expr *order_exp)
3197 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3198 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3199 gfc_constructor *head, *tail;
3205 /* Check that argument expression types are OK. */
3206 if (!is_constant_array_expr (source))
3209 if (!is_constant_array_expr (shape_exp))
3212 if (!is_constant_array_expr (pad))
3215 if (!is_constant_array_expr (order_exp))
3218 /* Proceed with simplification, unpacking the array. */
3226 e = gfc_get_array_element (shape_exp, rank);
3230 if (gfc_extract_int (e, &shape[rank]) != NULL)
3232 gfc_error ("Integer too large in shape specification at %L",
3240 if (rank >= GFC_MAX_DIMENSIONS)
3242 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3243 "at %L", &e->where);
3248 if (shape[rank] < 0)
3250 gfc_error ("Shape specification at %L cannot be negative",
3260 gfc_error ("Shape specification at %L cannot be the null array",
3265 /* Now unpack the order array if present. */
3266 if (order_exp == NULL)
3268 for (i = 0; i < rank; i++)
3273 for (i = 0; i < rank; i++)
3276 for (i = 0; i < rank; i++)
3278 e = gfc_get_array_element (order_exp, i);
3281 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3282 "size as SHAPE parameter", &order_exp->where);
3286 if (gfc_extract_int (e, &order[i]) != NULL)
3288 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3296 if (order[i] < 1 || order[i] > rank)
3298 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3307 gfc_error ("Invalid permutation in ORDER parameter at %L",
3316 /* Count the elements in the source and padding arrays. */
3321 gfc_array_size (pad, &size);
3322 npad = mpz_get_ui (size);
3326 gfc_array_size (source, &size);
3327 nsource = mpz_get_ui (size);
3330 /* If it weren't for that pesky permutation we could just loop
3331 through the source and round out any shortage with pad elements.
3332 But no, someone just had to have the compiler do something the
3333 user should be doing. */
3335 for (i = 0; i < rank; i++)
3340 /* Figure out which element to extract. */
3341 mpz_set_ui (index, 0);
3343 for (i = rank - 1; i >= 0; i--)
3345 mpz_add_ui (index, index, x[order[i]]);
3347 mpz_mul_ui (index, index, shape[order[i - 1]]);
3350 if (mpz_cmp_ui (index, INT_MAX) > 0)
3351 gfc_internal_error ("Reshaped array too large at %L", &e->where);
3353 j = mpz_get_ui (index);
3356 e = gfc_get_array_element (source, j);
3363 gfc_error ("PAD parameter required for short SOURCE parameter "
3364 "at %L", &source->where);
3369 e = gfc_get_array_element (pad, j);
3373 head = tail = gfc_get_constructor ();
3376 tail->next = gfc_get_constructor ();
3383 tail->where = e->where;
3386 /* Calculate the next element. */
3390 if (++x[i] < shape[i])
3401 e = gfc_get_expr ();
3402 e->where = source->where;
3403 e->expr_type = EXPR_ARRAY;
3404 e->value.constructor = head;
3405 e->shape = gfc_get_shape (rank);
3407 for (i = 0; i < rank; i++)
3408 mpz_init_set_ui (e->shape[i], shape[i]);
3416 gfc_free_constructor (head);
3418 return &gfc_bad_expr;
3423 gfc_simplify_rrspacing (gfc_expr *x)
3429 if (x->expr_type != EXPR_CONSTANT)
3432 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3434 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3436 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3438 /* Special case x = -0 and 0. */
3439 if (mpfr_sgn (result->value.real) == 0)
3441 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3445 /* | x * 2**(-e) | * 2**p. */
3446 e = - (long int) mpfr_get_exp (x->value.real);
3447 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3449 p = (long int) gfc_real_kinds[i].digits;
3450 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3452 return range_check (result, "RRSPACING");
3457 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3459 int k, neg_flag, power, exp_range;
3460 mpfr_t scale, radix;
3463 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3466 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3468 if (mpfr_sgn (x->value.real) == 0)
3470 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3474 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3476 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3478 /* This check filters out values of i that would overflow an int. */
3479 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3480 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3482 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3483 return &gfc_bad_expr;
3486 /* Compute scale = radix ** power. */
3487 power = mpz_get_si (i->value.integer);
3497 gfc_set_model_kind (x->ts.kind);
3500 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3501 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3504 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3506 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3511 return range_check (result, "SCALE");
3516 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
3521 size_t indx, len, lenc;
3522 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3525 return &gfc_bad_expr;
3527 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3530 if (b != NULL && b->value.logical != 0)
3535 result = gfc_constant_result (BT_INTEGER, k, &e->where);
3537 len = e->value.character.length;
3538 lenc = c->value.character.length;
3540 if (len == 0 || lenc == 0)
3548 indx = strcspn (e->value.character.string, c->value.character.string)
3556 for (indx = len; indx > 0; indx--)
3558 for (i = 0; i < lenc; i++)
3560 if (c->value.character.string[i]
3561 == e->value.character.string[indx - 1])
3569 mpz_set_ui (result->value.integer, indx);
3570 return range_check (result, "SCAN");
3575 gfc_simplify_selected_int_kind (gfc_expr *e)
3580 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3585 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3586 if (gfc_integer_kinds[i].range >= range
3587 && gfc_integer_kinds[i].kind < kind)
3588 kind = gfc_integer_kinds[i].kind;
3590 if (kind == INT_MAX)
3593 result = gfc_int_expr (kind);
3594 result->where = e->where;
3601 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3603 int range, precision, i, kind, found_precision, found_range;
3610 if (p->expr_type != EXPR_CONSTANT
3611 || gfc_extract_int (p, &precision) != NULL)
3619 if (q->expr_type != EXPR_CONSTANT
3620 || gfc_extract_int (q, &range) != NULL)
3625 found_precision = 0;
3628 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3630 if (gfc_real_kinds[i].precision >= precision)
3631 found_precision = 1;
3633 if (gfc_real_kinds[i].range >= range)
3636 if (gfc_real_kinds[i].precision >= precision
3637 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3638 kind = gfc_real_kinds[i].kind;
3641 if (kind == INT_MAX)
3645 if (!found_precision)
3651 result = gfc_int_expr (kind);
3652 result->where = (p != NULL) ? p->where : q->where;
3659 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3662 mpfr_t exp, absv, log2, pow2, frac;
3665 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3668 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3670 gfc_set_model_kind (x->ts.kind);
3672 if (mpfr_sgn (x->value.real) == 0)
3674 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3684 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3685 mpfr_log2 (log2, absv, GFC_RND_MODE);
3687 mpfr_trunc (log2, log2);
3688 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3690 /* Old exponent value, and fraction. */
3691 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3693 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3696 exp2 = (unsigned long) mpz_get_d (i->value.integer);
3697 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3704 return range_check (result, "SET_EXPONENT");
3709 gfc_simplify_shape (gfc_expr *source)
3711 mpz_t shape[GFC_MAX_DIMENSIONS];
3712 gfc_expr *result, *e, *f;
3717 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3720 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3723 ar = gfc_find_array_ref (source);
3725 t = gfc_array_ref_shape (ar, shape);
3727 for (n = 0; n < source->rank; n++)
3729 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3734 mpz_set (e->value.integer, shape[n]);
3735 mpz_clear (shape[n]);
3739 mpz_set_ui (e->value.integer, n + 1);
3741 f = gfc_simplify_size (source, e, NULL);
3745 gfc_free_expr (result);
3754 gfc_append_constructor (result, e);
3762 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3767 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
3770 return &gfc_bad_expr;
3774 if (gfc_array_size (array, &size) == FAILURE)
3779 if (dim->expr_type != EXPR_CONSTANT)
3782 d = mpz_get_ui (dim->value.integer) - 1;
3783 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3787 result = gfc_constant_result (BT_INTEGER, k, &array->where);
3788 mpz_set (result->value.integer, size);
3794 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
3798 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3801 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3806 mpz_abs (result->value.integer, x->value.integer);
3807 if (mpz_sgn (y->value.integer) < 0)
3808 mpz_neg (result->value.integer, result->value.integer);
3813 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3815 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3816 if (mpfr_sgn (y->value.real) < 0)
3817 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3822 gfc_internal_error ("Bad type in gfc_simplify_sign");
3830 gfc_simplify_sin (gfc_expr *x)
3835 if (x->expr_type != EXPR_CONSTANT)
3838 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3843 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3847 gfc_set_model (x->value.real);
3851 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
3852 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3853 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3855 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
3856 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3857 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3864 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3867 return range_check (result, "SIN");
3872 gfc_simplify_sinh (gfc_expr *x)
3876 if (x->expr_type != EXPR_CONSTANT)
3879 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3881 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
3883 return range_check (result, "SINH");
3887 /* The argument is always a double precision real that is converted to
3888 single precision. TODO: Rounding! */
3891 gfc_simplify_sngl (gfc_expr *a)
3895 if (a->expr_type != EXPR_CONSTANT)
3898 result = gfc_real2real (a, gfc_default_real_kind);
3899 return range_check (result, "SNGL");
3904 gfc_simplify_spacing (gfc_expr *x)
3910 if (x->expr_type != EXPR_CONSTANT)
3913 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3915 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3917 /* Special case x = 0 and -0. */
3918 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3919 if (mpfr_sgn (result->value.real) == 0)
3921 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3925 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3926 are the radix, exponent of x, and precision. This excludes the
3927 possibility of subnormal numbers. Fortran 2003 states the result is
3928 b**max(e - p, emin - 1). */
3930 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
3931 en = (long int) gfc_real_kinds[i].min_exponent - 1;
3932 en = en > ep ? en : ep;
3934 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3935 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
3937 return range_check (result, "SPACING");
3942 gfc_simplify_sqrt (gfc_expr *e)
3945 mpfr_t ac, ad, s, t, w;
3947 if (e->expr_type != EXPR_CONSTANT)
3950 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3955 if (mpfr_cmp_si (e->value.real, 0) < 0)
3957 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3962 /* Formula taken from Numerical Recipes to avoid over- and
3965 gfc_set_model (e->value.real);
3972 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3973 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3975 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3976 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3980 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3981 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3983 if (mpfr_cmp (ac, ad) >= 0)
3985 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3986 mpfr_mul (t, t, t, GFC_RND_MODE);
3987 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3988 mpfr_sqrt (t, t, GFC_RND_MODE);
3989 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3990 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3991 mpfr_sqrt (t, t, GFC_RND_MODE);
3992 mpfr_sqrt (s, ac, GFC_RND_MODE);
3993 mpfr_mul (w, s, t, GFC_RND_MODE);
3997 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3998 mpfr_mul (t, s, s, GFC_RND_MODE);
3999 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4000 mpfr_sqrt (t, t, GFC_RND_MODE);
4001 mpfr_abs (s, s, GFC_RND_MODE);
4002 mpfr_add (t, t, s, GFC_RND_MODE);
4003 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4004 mpfr_sqrt (t, t, GFC_RND_MODE);
4005 mpfr_sqrt (s, ad, GFC_RND_MODE);
4006 mpfr_mul (w, s, t, GFC_RND_MODE);
4009 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
4011 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4012 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
4013 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
4015 else if (mpfr_cmp_ui (w, 0) != 0
4016 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4017 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
4019 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4020 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
4021 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4023 else if (mpfr_cmp_ui (w, 0) != 0
4024 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4025 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
4027 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4028 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
4029 mpfr_neg (w, w, GFC_RND_MODE);
4030 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4033 gfc_internal_error ("invalid complex argument of SQRT at %L",
4045 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
4048 return range_check (result, "SQRT");
4051 gfc_free_expr (result);
4052 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
4053 return &gfc_bad_expr;
4058 gfc_simplify_tan (gfc_expr *x)
4063 if (x->expr_type != EXPR_CONSTANT)
4066 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4068 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4070 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
4072 return range_check (result, "TAN");
4077 gfc_simplify_tanh (gfc_expr *x)
4081 if (x->expr_type != EXPR_CONSTANT)
4084 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4086 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
4088 return range_check (result, "TANH");
4094 gfc_simplify_tiny (gfc_expr *e)
4099 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
4101 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
4102 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4109 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4112 gfc_expr *mold_element;
4115 size_t result_elt_size;
4118 unsigned char *buffer;
4120 if (!gfc_is_constant_expr (source)
4121 || (gfc_init_expr && !gfc_is_constant_expr (mold))
4122 || !gfc_is_constant_expr (size))
4125 if (source->expr_type == EXPR_FUNCTION)
4128 /* Calculate the size of the source. */
4129 if (source->expr_type == EXPR_ARRAY
4130 && gfc_array_size (source, &tmp) == FAILURE)
4131 gfc_internal_error ("Failure getting length of a constant array.");
4133 source_size = gfc_target_expr_size (source);
4135 /* Create an empty new expression with the appropriate characteristics. */
4136 result = gfc_constant_result (mold->ts.type, mold->ts.kind,
4138 result->ts = mold->ts;
4140 mold_element = mold->expr_type == EXPR_ARRAY
4141 ? mold->value.constructor->expr
4144 /* Set result character length, if needed. Note that this needs to be
4145 set even for array expressions, in order to pass this information into
4146 gfc_target_interpret_expr. */
4147 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
4148 result->value.character.length = mold_element->value.character.length;
4150 /* Set the number of elements in the result, and determine its size. */
4151 result_elt_size = gfc_target_expr_size (mold_element);
4152 if (result_elt_size == 0)
4154 gfc_free_expr (result);
4158 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4162 result->expr_type = EXPR_ARRAY;
4166 result_length = (size_t)mpz_get_ui (size->value.integer);
4169 result_length = source_size / result_elt_size;
4170 if (result_length * result_elt_size < source_size)
4174 result->shape = gfc_get_shape (1);
4175 mpz_init_set_ui (result->shape[0], result_length);
4177 result_size = result_length * result_elt_size;
4182 result_size = result_elt_size;
4185 if (gfc_option.warn_surprising && source_size < result_size)
4186 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4187 "source size %ld < result size %ld", &source->where,
4188 (long) source_size, (long) result_size);
4190 /* Allocate the buffer to store the binary version of the source. */
4191 buffer_size = MAX (source_size, result_size);
4192 buffer = (unsigned char*)alloca (buffer_size);
4194 /* Now write source to the buffer. */
4195 gfc_target_encode_expr (source, buffer, buffer_size);
4197 /* And read the buffer back into the new expression. */
4198 gfc_target_interpret_expr (buffer, buffer_size, result);
4205 gfc_simplify_trim (gfc_expr *e)
4208 int count, i, len, lentrim;
4210 if (e->expr_type != EXPR_CONSTANT)
4213 len = e->value.character.length;
4215 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4217 for (count = 0, i = 1; i <= len; ++i)
4219 if (e->value.character.string[len - i] == ' ')
4225 lentrim = len - count;
4227 result->value.character.length = lentrim;
4228 result->value.character.string = gfc_getmem (lentrim + 1);
4230 for (i = 0; i < lentrim; i++)
4231 result->value.character.string[i] = e->value.character.string[i];
4233 result->value.character.string[lentrim] = '\0'; /* For debugger */
4240 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4242 return simplify_bound (array, dim, kind, 1);
4247 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
4251 size_t index, len, lenset;
4253 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
4256 return &gfc_bad_expr;
4258 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4261 if (b != NULL && b->value.logical != 0)
4266 result = gfc_constant_result (BT_INTEGER, k, &s->where);
4268 len = s->value.character.length;
4269 lenset = set->value.character.length;
4273 mpz_set_ui (result->value.integer, 0);
4281 mpz_set_ui (result->value.integer, 1);
4285 index = strspn (s->value.character.string, set->value.character.string)
4295 mpz_set_ui (result->value.integer, len);
4298 for (index = len; index > 0; index --)
4300 for (i = 0; i < lenset; i++)
4302 if (s->value.character.string[index - 1]
4303 == set->value.character.string[i])
4311 mpz_set_ui (result->value.integer, index);
4317 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4322 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4325 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4326 if (x->ts.type == BT_INTEGER)
4328 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4329 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4331 else /* BT_LOGICAL */
4333 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4334 result->value.logical = (x->value.logical && !y->value.logical)
4335 || (!x->value.logical && y->value.logical);
4338 return range_check (result, "XOR");
4342 /****************** Constant simplification *****************/
4344 /* Master function to convert one constant to another. While this is
4345 used as a simplification function, it requires the destination type
4346 and kind information which is supplied by a special case in
4350 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4352 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4353 gfc_constructor *head, *c, *tail = NULL;
4367 f = gfc_int2complex;
4387 f = gfc_real2complex;
4398 f = gfc_complex2int;
4401 f = gfc_complex2real;
4404 f = gfc_complex2complex;
4430 f = gfc_hollerith2int;
4434 f = gfc_hollerith2real;
4438 f = gfc_hollerith2complex;
4442 f = gfc_hollerith2character;
4446 f = gfc_hollerith2logical;
4456 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4461 switch (e->expr_type)
4464 result = f (e, kind);
4466 return &gfc_bad_expr;
4470 if (!gfc_is_constant_expr (e))
4475 for (c = e->value.constructor; c; c = c->next)
4478 head = tail = gfc_get_constructor ();
4481 tail->next = gfc_get_constructor ();
4485 tail->where = c->where;
4487 if (c->iterator == NULL)
4488 tail->expr = f (c->expr, kind);
4491 g = gfc_convert_constant (c->expr, type, kind);
4492 if (g == &gfc_bad_expr)
4497 if (tail->expr == NULL)
4499 gfc_free_constructor (head);
4504 result = gfc_get_expr ();
4505 result->ts.type = type;
4506 result->ts.kind = kind;
4507 result->expr_type = EXPR_ARRAY;
4508 result->value.constructor = head;
4509 result->shape = gfc_copy_shape (e->shape, e->rank);
4510 result->where = e->where;
4511 result->rank = e->rank;