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 /* This one is a bear, but mainly has to do with shuffling elements. */
3170 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3171 gfc_expr *pad, gfc_expr *order_exp)
3173 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3174 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3175 gfc_constructor *head, *tail;
3181 /* Unpack the shape array. */
3182 if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
3185 if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
3189 && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
3192 if (order_exp != NULL
3193 && (order_exp->expr_type != EXPR_ARRAY
3194 || !gfc_is_constant_expr (order_exp)))
3203 e = gfc_get_array_element (shape_exp, rank);
3207 if (gfc_extract_int (e, &shape[rank]) != NULL)
3209 gfc_error ("Integer too large in shape specification at %L",
3217 if (rank >= GFC_MAX_DIMENSIONS)
3219 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3220 "at %L", &e->where);
3225 if (shape[rank] < 0)
3227 gfc_error ("Shape specification at %L cannot be negative",
3237 gfc_error ("Shape specification at %L cannot be the null array",
3242 /* Now unpack the order array if present. */
3243 if (order_exp == NULL)
3245 for (i = 0; i < rank; i++)
3250 for (i = 0; i < rank; i++)
3253 for (i = 0; i < rank; i++)
3255 e = gfc_get_array_element (order_exp, i);
3258 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3259 "size as SHAPE parameter", &order_exp->where);
3263 if (gfc_extract_int (e, &order[i]) != NULL)
3265 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3273 if (order[i] < 1 || order[i] > rank)
3275 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3284 gfc_error ("Invalid permutation in ORDER parameter at %L",
3293 /* Count the elements in the source and padding arrays. */
3298 gfc_array_size (pad, &size);
3299 npad = mpz_get_ui (size);
3303 gfc_array_size (source, &size);
3304 nsource = mpz_get_ui (size);
3307 /* If it weren't for that pesky permutation we could just loop
3308 through the source and round out any shortage with pad elements.
3309 But no, someone just had to have the compiler do something the
3310 user should be doing. */
3312 for (i = 0; i < rank; i++)
3317 /* Figure out which element to extract. */
3318 mpz_set_ui (index, 0);
3320 for (i = rank - 1; i >= 0; i--)
3322 mpz_add_ui (index, index, x[order[i]]);
3324 mpz_mul_ui (index, index, shape[order[i - 1]]);
3327 if (mpz_cmp_ui (index, INT_MAX) > 0)
3328 gfc_internal_error ("Reshaped array too large at %L", &e->where);
3330 j = mpz_get_ui (index);
3333 e = gfc_get_array_element (source, j);
3340 gfc_error ("PAD parameter required for short SOURCE parameter "
3341 "at %L", &source->where);
3346 e = gfc_get_array_element (pad, j);
3350 head = tail = gfc_get_constructor ();
3353 tail->next = gfc_get_constructor ();
3360 tail->where = e->where;
3363 /* Calculate the next element. */
3367 if (++x[i] < shape[i])
3378 e = gfc_get_expr ();
3379 e->where = source->where;
3380 e->expr_type = EXPR_ARRAY;
3381 e->value.constructor = head;
3382 e->shape = gfc_get_shape (rank);
3384 for (i = 0; i < rank; i++)
3385 mpz_init_set_ui (e->shape[i], shape[i]);
3393 gfc_free_constructor (head);
3395 return &gfc_bad_expr;
3400 gfc_simplify_rrspacing (gfc_expr *x)
3406 if (x->expr_type != EXPR_CONSTANT)
3409 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3411 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3413 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3415 /* Special case x = -0 and 0. */
3416 if (mpfr_sgn (result->value.real) == 0)
3418 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3422 /* | x * 2**(-e) | * 2**p. */
3423 e = - (long int) mpfr_get_exp (x->value.real);
3424 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3426 p = (long int) gfc_real_kinds[i].digits;
3427 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3429 return range_check (result, "RRSPACING");
3434 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3436 int k, neg_flag, power, exp_range;
3437 mpfr_t scale, radix;
3440 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3443 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3445 if (mpfr_sgn (x->value.real) == 0)
3447 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3451 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3453 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3455 /* This check filters out values of i that would overflow an int. */
3456 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3457 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3459 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3460 return &gfc_bad_expr;
3463 /* Compute scale = radix ** power. */
3464 power = mpz_get_si (i->value.integer);
3474 gfc_set_model_kind (x->ts.kind);
3477 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3478 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3481 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3483 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3488 return range_check (result, "SCALE");
3493 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
3498 size_t indx, len, lenc;
3499 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3502 return &gfc_bad_expr;
3504 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3507 if (b != NULL && b->value.logical != 0)
3512 result = gfc_constant_result (BT_INTEGER, k, &e->where);
3514 len = e->value.character.length;
3515 lenc = c->value.character.length;
3517 if (len == 0 || lenc == 0)
3525 indx = strcspn (e->value.character.string, c->value.character.string)
3533 for (indx = len; indx > 0; indx--)
3535 for (i = 0; i < lenc; i++)
3537 if (c->value.character.string[i]
3538 == e->value.character.string[indx - 1])
3546 mpz_set_ui (result->value.integer, indx);
3547 return range_check (result, "SCAN");
3552 gfc_simplify_selected_int_kind (gfc_expr *e)
3557 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3562 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3563 if (gfc_integer_kinds[i].range >= range
3564 && gfc_integer_kinds[i].kind < kind)
3565 kind = gfc_integer_kinds[i].kind;
3567 if (kind == INT_MAX)
3570 result = gfc_int_expr (kind);
3571 result->where = e->where;
3578 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3580 int range, precision, i, kind, found_precision, found_range;
3587 if (p->expr_type != EXPR_CONSTANT
3588 || gfc_extract_int (p, &precision) != NULL)
3596 if (q->expr_type != EXPR_CONSTANT
3597 || gfc_extract_int (q, &range) != NULL)
3602 found_precision = 0;
3605 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3607 if (gfc_real_kinds[i].precision >= precision)
3608 found_precision = 1;
3610 if (gfc_real_kinds[i].range >= range)
3613 if (gfc_real_kinds[i].precision >= precision
3614 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3615 kind = gfc_real_kinds[i].kind;
3618 if (kind == INT_MAX)
3622 if (!found_precision)
3628 result = gfc_int_expr (kind);
3629 result->where = (p != NULL) ? p->where : q->where;
3636 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3639 mpfr_t exp, absv, log2, pow2, frac;
3642 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3645 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3647 gfc_set_model_kind (x->ts.kind);
3649 if (mpfr_sgn (x->value.real) == 0)
3651 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3661 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3662 mpfr_log2 (log2, absv, GFC_RND_MODE);
3664 mpfr_trunc (log2, log2);
3665 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3667 /* Old exponent value, and fraction. */
3668 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3670 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3673 exp2 = (unsigned long) mpz_get_d (i->value.integer);
3674 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3681 return range_check (result, "SET_EXPONENT");
3686 gfc_simplify_shape (gfc_expr *source)
3688 mpz_t shape[GFC_MAX_DIMENSIONS];
3689 gfc_expr *result, *e, *f;
3694 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3697 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3700 ar = gfc_find_array_ref (source);
3702 t = gfc_array_ref_shape (ar, shape);
3704 for (n = 0; n < source->rank; n++)
3706 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3711 mpz_set (e->value.integer, shape[n]);
3712 mpz_clear (shape[n]);
3716 mpz_set_ui (e->value.integer, n + 1);
3718 f = gfc_simplify_size (source, e, NULL);
3722 gfc_free_expr (result);
3731 gfc_append_constructor (result, e);
3739 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3744 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
3747 return &gfc_bad_expr;
3751 if (gfc_array_size (array, &size) == FAILURE)
3756 if (dim->expr_type != EXPR_CONSTANT)
3759 d = mpz_get_ui (dim->value.integer) - 1;
3760 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3764 result = gfc_constant_result (BT_INTEGER, k, &array->where);
3765 mpz_set (result->value.integer, size);
3771 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
3775 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3778 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3783 mpz_abs (result->value.integer, x->value.integer);
3784 if (mpz_sgn (y->value.integer) < 0)
3785 mpz_neg (result->value.integer, result->value.integer);
3790 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3792 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3793 if (mpfr_sgn (y->value.real) < 0)
3794 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3799 gfc_internal_error ("Bad type in gfc_simplify_sign");
3807 gfc_simplify_sin (gfc_expr *x)
3812 if (x->expr_type != EXPR_CONSTANT)
3815 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3820 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3824 gfc_set_model (x->value.real);
3828 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
3829 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3830 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3832 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
3833 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3834 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3841 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3844 return range_check (result, "SIN");
3849 gfc_simplify_sinh (gfc_expr *x)
3853 if (x->expr_type != EXPR_CONSTANT)
3856 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3858 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
3860 return range_check (result, "SINH");
3864 /* The argument is always a double precision real that is converted to
3865 single precision. TODO: Rounding! */
3868 gfc_simplify_sngl (gfc_expr *a)
3872 if (a->expr_type != EXPR_CONSTANT)
3875 result = gfc_real2real (a, gfc_default_real_kind);
3876 return range_check (result, "SNGL");
3881 gfc_simplify_spacing (gfc_expr *x)
3887 if (x->expr_type != EXPR_CONSTANT)
3890 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3892 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3894 /* Special case x = 0 and -0. */
3895 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3896 if (mpfr_sgn (result->value.real) == 0)
3898 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3902 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
3903 are the radix, exponent of x, and precision. This excludes the
3904 possibility of subnormal numbers. Fortran 2003 states the result is
3905 b**max(e - p, emin - 1). */
3907 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
3908 en = (long int) gfc_real_kinds[i].min_exponent - 1;
3909 en = en > ep ? en : ep;
3911 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3912 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
3914 return range_check (result, "SPACING");
3919 gfc_simplify_sqrt (gfc_expr *e)
3922 mpfr_t ac, ad, s, t, w;
3924 if (e->expr_type != EXPR_CONSTANT)
3927 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3932 if (mpfr_cmp_si (e->value.real, 0) < 0)
3934 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3939 /* Formula taken from Numerical Recipes to avoid over- and
3942 gfc_set_model (e->value.real);
3949 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3950 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3952 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3953 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3957 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3958 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3960 if (mpfr_cmp (ac, ad) >= 0)
3962 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3963 mpfr_mul (t, t, t, GFC_RND_MODE);
3964 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3965 mpfr_sqrt (t, t, GFC_RND_MODE);
3966 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3967 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3968 mpfr_sqrt (t, t, GFC_RND_MODE);
3969 mpfr_sqrt (s, ac, GFC_RND_MODE);
3970 mpfr_mul (w, s, t, GFC_RND_MODE);
3974 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3975 mpfr_mul (t, s, s, GFC_RND_MODE);
3976 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3977 mpfr_sqrt (t, t, GFC_RND_MODE);
3978 mpfr_abs (s, s, GFC_RND_MODE);
3979 mpfr_add (t, t, s, GFC_RND_MODE);
3980 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3981 mpfr_sqrt (t, t, GFC_RND_MODE);
3982 mpfr_sqrt (s, ad, GFC_RND_MODE);
3983 mpfr_mul (w, s, t, GFC_RND_MODE);
3986 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3988 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3989 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3990 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3992 else if (mpfr_cmp_ui (w, 0) != 0
3993 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3994 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3996 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3997 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3998 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4000 else if (mpfr_cmp_ui (w, 0) != 0
4001 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4002 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
4004 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4005 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
4006 mpfr_neg (w, w, GFC_RND_MODE);
4007 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4010 gfc_internal_error ("invalid complex argument of SQRT at %L",
4022 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
4025 return range_check (result, "SQRT");
4028 gfc_free_expr (result);
4029 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
4030 return &gfc_bad_expr;
4035 gfc_simplify_tan (gfc_expr *x)
4040 if (x->expr_type != EXPR_CONSTANT)
4043 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4045 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4047 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
4049 return range_check (result, "TAN");
4054 gfc_simplify_tanh (gfc_expr *x)
4058 if (x->expr_type != EXPR_CONSTANT)
4061 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4063 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
4065 return range_check (result, "TANH");
4071 gfc_simplify_tiny (gfc_expr *e)
4076 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
4078 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
4079 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4086 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4089 gfc_expr *mold_element;
4092 size_t result_elt_size;
4095 unsigned char *buffer;
4097 if (!gfc_is_constant_expr (source)
4098 || (gfc_init_expr && !gfc_is_constant_expr (mold))
4099 || !gfc_is_constant_expr (size))
4102 if (source->expr_type == EXPR_FUNCTION)
4105 /* Calculate the size of the source. */
4106 if (source->expr_type == EXPR_ARRAY
4107 && gfc_array_size (source, &tmp) == FAILURE)
4108 gfc_internal_error ("Failure getting length of a constant array.");
4110 source_size = gfc_target_expr_size (source);
4112 /* Create an empty new expression with the appropriate characteristics. */
4113 result = gfc_constant_result (mold->ts.type, mold->ts.kind,
4115 result->ts = mold->ts;
4117 mold_element = mold->expr_type == EXPR_ARRAY
4118 ? mold->value.constructor->expr
4121 /* Set result character length, if needed. Note that this needs to be
4122 set even for array expressions, in order to pass this information into
4123 gfc_target_interpret_expr. */
4124 if (result->ts.type == BT_CHARACTER)
4125 result->value.character.length = mold_element->value.character.length;
4127 /* Set the number of elements in the result, and determine its size. */
4128 result_elt_size = gfc_target_expr_size (mold_element);
4129 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4133 result->expr_type = EXPR_ARRAY;
4137 result_length = (size_t)mpz_get_ui (size->value.integer);
4140 result_length = source_size / result_elt_size;
4141 if (result_length * result_elt_size < source_size)
4145 result->shape = gfc_get_shape (1);
4146 mpz_init_set_ui (result->shape[0], result_length);
4148 result_size = result_length * result_elt_size;
4153 result_size = result_elt_size;
4156 if (gfc_option.warn_surprising && source_size < result_size)
4157 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4158 "source size %ld < result size %ld", &source->where,
4159 (long) source_size, (long) result_size);
4161 /* Allocate the buffer to store the binary version of the source. */
4162 buffer_size = MAX (source_size, result_size);
4163 buffer = (unsigned char*)alloca (buffer_size);
4165 /* Now write source to the buffer. */
4166 gfc_target_encode_expr (source, buffer, buffer_size);
4168 /* And read the buffer back into the new expression. */
4169 gfc_target_interpret_expr (buffer, buffer_size, result);
4176 gfc_simplify_trim (gfc_expr *e)
4179 int count, i, len, lentrim;
4181 if (e->expr_type != EXPR_CONSTANT)
4184 len = e->value.character.length;
4186 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4188 for (count = 0, i = 1; i <= len; ++i)
4190 if (e->value.character.string[len - i] == ' ')
4196 lentrim = len - count;
4198 result->value.character.length = lentrim;
4199 result->value.character.string = gfc_getmem (lentrim + 1);
4201 for (i = 0; i < lentrim; i++)
4202 result->value.character.string[i] = e->value.character.string[i];
4204 result->value.character.string[lentrim] = '\0'; /* For debugger */
4211 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4213 return simplify_bound (array, dim, kind, 1);
4218 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
4222 size_t index, len, lenset;
4224 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
4227 return &gfc_bad_expr;
4229 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4232 if (b != NULL && b->value.logical != 0)
4237 result = gfc_constant_result (BT_INTEGER, k, &s->where);
4239 len = s->value.character.length;
4240 lenset = set->value.character.length;
4244 mpz_set_ui (result->value.integer, 0);
4252 mpz_set_ui (result->value.integer, 1);
4256 index = strspn (s->value.character.string, set->value.character.string)
4266 mpz_set_ui (result->value.integer, len);
4269 for (index = len; index > 0; index --)
4271 for (i = 0; i < lenset; i++)
4273 if (s->value.character.string[index - 1]
4274 == set->value.character.string[i])
4282 mpz_set_ui (result->value.integer, index);
4288 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4293 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4296 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4297 if (x->ts.type == BT_INTEGER)
4299 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4300 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4302 else /* BT_LOGICAL */
4304 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4305 result->value.logical = (x->value.logical && !y->value.logical)
4306 || (!x->value.logical && y->value.logical);
4309 return range_check (result, "XOR");
4313 /****************** Constant simplification *****************/
4315 /* Master function to convert one constant to another. While this is
4316 used as a simplification function, it requires the destination type
4317 and kind information which is supplied by a special case in
4321 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4323 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4324 gfc_constructor *head, *c, *tail = NULL;
4338 f = gfc_int2complex;
4358 f = gfc_real2complex;
4369 f = gfc_complex2int;
4372 f = gfc_complex2real;
4375 f = gfc_complex2complex;
4401 f = gfc_hollerith2int;
4405 f = gfc_hollerith2real;
4409 f = gfc_hollerith2complex;
4413 f = gfc_hollerith2character;
4417 f = gfc_hollerith2logical;
4427 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4432 switch (e->expr_type)
4435 result = f (e, kind);
4437 return &gfc_bad_expr;
4441 if (!gfc_is_constant_expr (e))
4446 for (c = e->value.constructor; c; c = c->next)
4449 head = tail = gfc_get_constructor ();
4452 tail->next = gfc_get_constructor ();
4456 tail->where = c->where;
4458 if (c->iterator == NULL)
4459 tail->expr = f (c->expr, kind);
4462 g = gfc_convert_constant (c->expr, type, kind);
4463 if (g == &gfc_bad_expr)
4468 if (tail->expr == NULL)
4470 gfc_free_constructor (head);
4475 result = gfc_get_expr ();
4476 result->ts.type = type;
4477 result->ts.kind = kind;
4478 result->expr_type = EXPR_ARRAY;
4479 result->value.constructor = head;
4480 result->shape = gfc_copy_shape (e->shape, e->rank);
4481 result->where = e->where;
4482 result->rank = e->rank;