projects / gcc.git / blob
? search:


429c5151d2e8be2db35afad04db6b1cea11ef159
[gcc.git] / gcc / fortran / simplify.c
1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught & Katherine Holcomb
5
6 This file is part of GCC.
7
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
11 version.
12
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
16 for more details.
17
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/>. */
21
22 #include "config.h"
23 #include "system.h"
24 #include "flags.h"
25 #include "gfortran.h"
26 #include "arith.h"
27 #include "intrinsic.h"
28 #include "target-memory.h"
29
30 gfc_expr gfc_bad_expr;
31
32
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.
36
37 The return convention is that each simplification function returns:
38
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.
42
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
47 retained.
48
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
53
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
59 its processing.
60
61 Array arguments are never passed to these subroutines.
62
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. */
66
67 /* Range checks an expression node. If all goes well, returns the
68 node, otherwise returns &gfc_bad_expr and frees the node. */
69
70 static gfc_expr *
71 range_check (gfc_expr *result, const char *name)
72 {
73 if (result == NULL)
74 return &gfc_bad_expr;
75
76 switch (gfc_range_check (result))
77 {
78 case ARITH_OK:
79 return result;
80
81 case ARITH_OVERFLOW:
82 gfc_error ("Result of %s overflows its kind at %L", name,
83 &result->where);
84 break;
85
86 case ARITH_UNDERFLOW:
87 gfc_error ("Result of %s underflows its kind at %L", name,
88 &result->where);
89 break;
90
91 case ARITH_NAN:
92 gfc_error ("Result of %s is NaN at %L", name, &result->where);
93 break;
94
95 default:
96 gfc_error ("Result of %s gives range error for its kind at %L", name,
97 &result->where);
98 break;
99 }
100
101 gfc_free_expr (result);
102 return &gfc_bad_expr;
103 }
104
105
106 /* A helper function that gets an optional and possibly missing
107 kind parameter. Returns the kind, -1 if something went wrong. */
108
109 static int
110 get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
111 {
112 int kind;
113
114 if (k == NULL)
115 return default_kind;
116
117 if (k->expr_type != EXPR_CONSTANT)
118 {
119 gfc_error ("KIND parameter of %s at %L must be an initialization "
120 "expression", name, &k->where);
121 return -1;
122 }
123
124 if (gfc_extract_int (k, &kind) != NULL
125 || gfc_validate_kind (type, kind, true) < 0)
126 {
127 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
128 return -1;
129 }
130
131 return kind;
132 }
133
134
135 /* Helper function to get an integer constant with a kind number given
136 by an integer constant expression. */
137 static gfc_expr *
138 int_expr_with_kind (int i, gfc_expr *kind, const char *name)
139 {
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)
143 return NULL;
144 else
145 return res;
146 }
147
148
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. */
153
154 static void
155 convert_mpz_to_unsigned (mpz_t x, int bitsize)
156 {
157 mpz_t mask;
158
159 if (mpz_sgn (x) < 0)
160 {
161 /* Confirm that no bits above the signed range are unset. */
162 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
163
164 mpz_init_set_ui (mask, 1);
165 mpz_mul_2exp (mask, mask, bitsize);
166 mpz_sub_ui (mask, mask, 1);
167
168 mpz_and (x, x, mask);
169
170 mpz_clear (mask);
171 }
172 else
173 {
174 /* Confirm that no bits above the signed range are set. */
175 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
176 }
177 }
178
179
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. */
184
185 static void
186 convert_mpz_to_signed (mpz_t x, int bitsize)
187 {
188 mpz_t mask;
189
190 /* Confirm that no bits above the unsigned range are set. */
191 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
192
193 if (mpz_tstbit (x, bitsize - 1) == 1)
194 {
195 mpz_init_set_ui (mask, 1);
196 mpz_mul_2exp (mask, mask, bitsize);
197 mpz_sub_ui (mask, mask, 1);
198
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
202 negative number. */
203 mpz_com (x, x);
204 mpz_add_ui (x, x, 1);
205 mpz_and (x, x, mask);
206
207 mpz_neg (x, x);
208
209 mpz_clear (mask);
210 }
211 }
212
213
214 /********************** Simplification functions *****************************/
215
216 gfc_expr *
217 gfc_simplify_abs (gfc_expr *e)
218 {
219 gfc_expr *result;
220
221 if (e->expr_type != EXPR_CONSTANT)
222 return NULL;
223
224 switch (e->ts.type)
225 {
226 case BT_INTEGER:
227 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
228
229 mpz_abs (result->value.integer, e->value.integer);
230
231 result = range_check (result, "IABS");
232 break;
233
234 case BT_REAL:
235 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
236
237 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
238
239 result = range_check (result, "ABS");
240 break;
241
242 case BT_COMPLEX:
243 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
244
245 gfc_set_model_kind (e->ts.kind);
246
247 mpfr_hypot (result->value.real, e->value.complex.r,
248 e->value.complex.i, GFC_RND_MODE);
249 result = range_check (result, "CABS");
250 break;
251
252 default:
253 gfc_internal_error ("gfc_simplify_abs(): Bad type");
254 }
255
256 return result;
257 }
258
259
260 static gfc_expr *
261 simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
262 {
263 gfc_expr *result;
264 int kind;
265 bool too_large = false;
266
267 if (e->expr_type != EXPR_CONSTANT)
268 return NULL;
269
270 kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
271 if (kind == -1)
272 return &gfc_bad_expr;
273
274 if (mpz_cmp_si (e->value.integer, 0) < 0)
275 {
276 gfc_error ("Argument of %s function at %L is negative", name,
277 &e->where);
278 return &gfc_bad_expr;
279 }
280
281 if (ascii && gfc_option.warn_surprising
282 && mpz_cmp_si (e->value.integer, 127) > 0)
283 gfc_warning ("Argument of %s function at %L outside of range [0,127]",
284 name, &e->where);
285
286 if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
287 too_large = true;
288 else if (kind == 4)
289 {
290 mpz_t t;
291 mpz_init_set_ui (t, 2);
292 mpz_pow_ui (t, t, 32);
293 mpz_sub_ui (t, t, 1);
294 if (mpz_cmp (e->value.integer, t) > 0)
295 too_large = true;
296 mpz_clear (t);
297 }
298
299 if (too_large)
300 {
301 gfc_error ("Argument of %s function at %L is too large for the "
302 "collating sequence of kind %d", name, &e->where, kind);
303 return &gfc_bad_expr;
304 }
305
306 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
307 result->value.character.string = gfc_get_wide_string (2);
308 result->value.character.length = 1;
309 result->value.character.string[0] = mpz_get_ui (e->value.integer);
310 result->value.character.string[1] = '\0'; /* For debugger */
311 return result;
312 }
313
314
315
316 /* We use the processor's collating sequence, because all
317 systems that gfortran currently works on are ASCII. */
318
319 gfc_expr *
320 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
321 {
322 return simplify_achar_char (e, k, "ACHAR", true);
323 }
324
325
326 gfc_expr *
327 gfc_simplify_acos (gfc_expr *x)
328 {
329 gfc_expr *result;
330
331 if (x->expr_type != EXPR_CONSTANT)
332 return NULL;
333
334 if (mpfr_cmp_si (x->value.real, 1) > 0
335 || mpfr_cmp_si (x->value.real, -1) < 0)
336 {
337 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
338 &x->where);
339 return &gfc_bad_expr;
340 }
341
342 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
343
344 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
345
346 return range_check (result, "ACOS");
347 }
348
349 gfc_expr *
350 gfc_simplify_acosh (gfc_expr *x)
351 {
352 gfc_expr *result;
353
354 if (x->expr_type != EXPR_CONSTANT)
355 return NULL;
356
357 if (mpfr_cmp_si (x->value.real, 1) < 0)
358 {
359 gfc_error ("Argument of ACOSH at %L must not be less than 1",
360 &x->where);
361 return &gfc_bad_expr;
362 }
363
364 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
365
366 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
367
368 return range_check (result, "ACOSH");
369 }
370
371 gfc_expr *
372 gfc_simplify_adjustl (gfc_expr *e)
373 {
374 gfc_expr *result;
375 int count, i, len;
376 gfc_char_t ch;
377
378 if (e->expr_type != EXPR_CONSTANT)
379 return NULL;
380
381 len = e->value.character.length;
382
383 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
384
385 result->value.character.length = len;
386 result->value.character.string = gfc_get_wide_string (len + 1);
387
388 for (count = 0, i = 0; i < len; ++i)
389 {
390 ch = e->value.character.string[i];
391 if (ch != ' ')
392 break;
393 ++count;
394 }
395
396 for (i = 0; i < len - count; ++i)
397 result->value.character.string[i] = e->value.character.string[count + i];
398
399 for (i = len - count; i < len; ++i)
400 result->value.character.string[i] = ' ';
401
402 result->value.character.string[len] = '\0'; /* For debugger */
403
404 return result;
405 }
406
407
408 gfc_expr *
409 gfc_simplify_adjustr (gfc_expr *e)
410 {
411 gfc_expr *result;
412 int count, i, len;
413 gfc_char_t ch;
414
415 if (e->expr_type != EXPR_CONSTANT)
416 return NULL;
417
418 len = e->value.character.length;
419
420 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
421
422 result->value.character.length = len;
423 result->value.character.string = gfc_get_wide_string (len + 1);
424
425 for (count = 0, i = len - 1; i >= 0; --i)
426 {
427 ch = e->value.character.string[i];
428 if (ch != ' ')
429 break;
430 ++count;
431 }
432
433 for (i = 0; i < count; ++i)
434 result->value.character.string[i] = ' ';
435
436 for (i = count; i < len; ++i)
437 result->value.character.string[i] = e->value.character.string[i - count];
438
439 result->value.character.string[len] = '\0'; /* For debugger */
440
441 return result;
442 }
443
444
445 gfc_expr *
446 gfc_simplify_aimag (gfc_expr *e)
447 {
448 gfc_expr *result;
449
450 if (e->expr_type != EXPR_CONSTANT)
451 return NULL;
452
453 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
454 mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
455
456 return range_check (result, "AIMAG");
457 }
458
459
460 gfc_expr *
461 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
462 {
463 gfc_expr *rtrunc, *result;
464 int kind;
465
466 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
467 if (kind == -1)
468 return &gfc_bad_expr;
469
470 if (e->expr_type != EXPR_CONSTANT)
471 return NULL;
472
473 rtrunc = gfc_copy_expr (e);
474
475 mpfr_trunc (rtrunc->value.real, e->value.real);
476
477 result = gfc_real2real (rtrunc, kind);
478 gfc_free_expr (rtrunc);
479
480 return range_check (result, "AINT");
481 }
482
483
484 gfc_expr *
485 gfc_simplify_dint (gfc_expr *e)
486 {
487 gfc_expr *rtrunc, *result;
488
489 if (e->expr_type != EXPR_CONSTANT)
490 return NULL;
491
492 rtrunc = gfc_copy_expr (e);
493
494 mpfr_trunc (rtrunc->value.real, e->value.real);
495
496 result = gfc_real2real (rtrunc, gfc_default_double_kind);
497 gfc_free_expr (rtrunc);
498
499 return range_check (result, "DINT");
500 }
501
502
503 gfc_expr *
504 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
505 {
506 gfc_expr *result;
507 int kind;
508
509 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
510 if (kind == -1)
511 return &gfc_bad_expr;
512
513 if (e->expr_type != EXPR_CONSTANT)
514 return NULL;
515
516 result = gfc_constant_result (e->ts.type, kind, &e->where);
517
518 mpfr_round (result->value.real, e->value.real);
519
520 return range_check (result, "ANINT");
521 }
522
523
524 gfc_expr *
525 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
526 {
527 gfc_expr *result;
528 int kind;
529
530 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
531 return NULL;
532
533 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
534 if (x->ts.type == BT_INTEGER)
535 {
536 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
537 mpz_and (result->value.integer, x->value.integer, y->value.integer);
538 return range_check (result, "AND");
539 }
540 else /* BT_LOGICAL */
541 {
542 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
543 result->value.logical = x->value.logical && y->value.logical;
544 return result;
545 }
546 }
547
548
549 gfc_expr *
550 gfc_simplify_dnint (gfc_expr *e)
551 {
552 gfc_expr *result;
553
554 if (e->expr_type != EXPR_CONSTANT)
555 return NULL;
556
557 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
558
559 mpfr_round (result->value.real, e->value.real);
560
561 return range_check (result, "DNINT");
562 }
563
564
565 gfc_expr *
566 gfc_simplify_asin (gfc_expr *x)
567 {
568 gfc_expr *result;
569
570 if (x->expr_type != EXPR_CONSTANT)
571 return NULL;
572
573 if (mpfr_cmp_si (x->value.real, 1) > 0
574 || mpfr_cmp_si (x->value.real, -1) < 0)
575 {
576 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
577 &x->where);
578 return &gfc_bad_expr;
579 }
580
581 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
582
583 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
584
585 return range_check (result, "ASIN");
586 }
587
588
589 gfc_expr *
590 gfc_simplify_asinh (gfc_expr *x)
591 {
592 gfc_expr *result;
593
594 if (x->expr_type != EXPR_CONSTANT)
595 return NULL;
596
597 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
598
599 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
600
601 return range_check (result, "ASINH");
602 }
603
604
605 gfc_expr *
606 gfc_simplify_atan (gfc_expr *x)
607 {
608 gfc_expr *result;
609
610 if (x->expr_type != EXPR_CONSTANT)
611 return NULL;
612
613 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
614
615 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
616
617 return range_check (result, "ATAN");
618 }
619
620
621 gfc_expr *
622 gfc_simplify_atanh (gfc_expr *x)
623 {
624 gfc_expr *result;
625
626 if (x->expr_type != EXPR_CONSTANT)
627 return NULL;
628
629 if (mpfr_cmp_si (x->value.real, 1) >= 0
630 || mpfr_cmp_si (x->value.real, -1) <= 0)
631 {
632 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
633 &x->where);
634 return &gfc_bad_expr;
635 }
636
637 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
638
639 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
640
641 return range_check (result, "ATANH");
642 }
643
644
645 gfc_expr *
646 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
647 {
648 gfc_expr *result;
649
650 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
651 return NULL;
652
653 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
654 {
655 gfc_error ("If first argument of ATAN2 %L is zero, then the "
656 "second argument must not be zero", &x->where);
657 return &gfc_bad_expr;
658 }
659
660 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
661
662 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
663
664 return range_check (result, "ATAN2");
665 }
666
667
668 gfc_expr *
669 gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
670 {
671 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
672 gfc_expr *result;
673
674 if (x->expr_type != EXPR_CONSTANT)
675 return NULL;
676
677 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
678 mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
679
680 return range_check (result, "BESSEL_J0");
681 #else
682 return NULL;
683 #endif
684 }
685
686
687 gfc_expr *
688 gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
689 {
690 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
691 gfc_expr *result;
692
693 if (x->expr_type != EXPR_CONSTANT)
694 return NULL;
695
696 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
697 mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
698
699 return range_check (result, "BESSEL_J1");
700 #else
701 return NULL;
702 #endif
703 }
704
705
706 gfc_expr *
707 gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
708 gfc_expr *x ATTRIBUTE_UNUSED)
709 {
710 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
711 gfc_expr *result;
712 long n;
713
714 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
715 return NULL;
716
717 n = mpz_get_si (order->value.integer);
718 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
719 mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
720
721 return range_check (result, "BESSEL_JN");
722 #else
723 return NULL;
724 #endif
725 }
726
727
728 gfc_expr *
729 gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
730 {
731 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
732 gfc_expr *result;
733
734 if (x->expr_type != EXPR_CONSTANT)
735 return NULL;
736
737 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
738 mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
739
740 return range_check (result, "BESSEL_Y0");
741 #else
742 return NULL;
743 #endif
744 }
745
746
747 gfc_expr *
748 gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
749 {
750 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
751 gfc_expr *result;
752
753 if (x->expr_type != EXPR_CONSTANT)
754 return NULL;
755
756 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
757 mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
758
759 return range_check (result, "BESSEL_Y1");
760 #else
761 return NULL;
762 #endif
763 }
764
765
766 gfc_expr *
767 gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
768 gfc_expr *x ATTRIBUTE_UNUSED)
769 {
770 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
771 gfc_expr *result;
772 long n;
773
774 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
775 return NULL;
776
777 n = mpz_get_si (order->value.integer);
778 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
779 mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
780
781 return range_check (result, "BESSEL_YN");
782 #else
783 return NULL;
784 #endif
785 }
786
787
788 gfc_expr *
789 gfc_simplify_bit_size (gfc_expr *e)
790 {
791 gfc_expr *result;
792 int i;
793
794 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
795 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
796 mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
797
798 return result;
799 }
800
801
802 gfc_expr *
803 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
804 {
805 int b;
806
807 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
808 return NULL;
809
810 if (gfc_extract_int (bit, &b) != NULL || b < 0)
811 return gfc_logical_expr (0, &e->where);
812
813 return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
814 }
815
816
817 gfc_expr *
818 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
819 {
820 gfc_expr *ceil, *result;
821 int kind;
822
823 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
824 if (kind == -1)
825 return &gfc_bad_expr;
826
827 if (e->expr_type != EXPR_CONSTANT)
828 return NULL;
829
830 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
831
832 ceil = gfc_copy_expr (e);
833
834 mpfr_ceil (ceil->value.real, e->value.real);
835 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
836
837 gfc_free_expr (ceil);
838
839 return range_check (result, "CEILING");
840 }
841
842
843 gfc_expr *
844 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
845 {
846 return simplify_achar_char (e, k, "CHAR", false);
847 }
848
849
850 /* Common subroutine for simplifying CMPLX and DCMPLX. */
851
852 static gfc_expr *
853 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
854 {
855 gfc_expr *result;
856
857 result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
858
859 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
860
861 switch (x->ts.type)
862 {
863 case BT_INTEGER:
864 if (!x->is_boz)
865 mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
866 break;
867
868 case BT_REAL:
869 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
870 break;
871
872 case BT_COMPLEX:
873 mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
874 mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
875 break;
876
877 default:
878 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
879 }
880
881 if (y != NULL)
882 {
883 switch (y->ts.type)
884 {
885 case BT_INTEGER:
886 if (!y->is_boz)
887 mpfr_set_z (result->value.complex.i, y->value.integer,
888 GFC_RND_MODE);
889 break;
890
891 case BT_REAL:
892 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
893 break;
894
895 default:
896 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
897 }
898 }
899
900 /* Handle BOZ. */
901 if (x->is_boz)
902 {
903 gfc_typespec ts;
904 gfc_clear_ts (&ts);
905 ts.kind = result->ts.kind;
906 ts.type = BT_REAL;
907 if (!gfc_convert_boz (x, &ts))
908 return &gfc_bad_expr;
909 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
910 }
911
912 if (y && y->is_boz)
913 {
914 gfc_typespec ts;
915 gfc_clear_ts (&ts);
916 ts.kind = result->ts.kind;
917 ts.type = BT_REAL;
918 if (!gfc_convert_boz (y, &ts))
919 return &gfc_bad_expr;
920 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
921 }
922
923 return range_check (result, name);
924 }
925
926
927 /* Function called when we won't simplify an expression like CMPLX (or
928 COMPLEX or DCMPLX) but still want to convert BOZ arguments. */
929
930 static gfc_expr *
931 only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
932 {
933 gfc_typespec ts;
934 gfc_clear_ts (&ts);
935 ts.type = BT_REAL;
936 ts.kind = kind;
937
938 if (x->is_boz && !gfc_convert_boz (x, &ts))
939 return &gfc_bad_expr;
940
941 if (y && y->is_boz && !gfc_convert_boz (y, &ts))
942 return &gfc_bad_expr;
943
944 return NULL;
945 }
946
947
948 gfc_expr *
949 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
950 {
951 int kind;
952
953 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
954 if (kind == -1)
955 return &gfc_bad_expr;
956
957 if (x->expr_type != EXPR_CONSTANT
958 || (y != NULL && y->expr_type != EXPR_CONSTANT))
959 return only_convert_cmplx_boz (x, y, kind);
960
961 return simplify_cmplx ("CMPLX", x, y, kind);
962 }
963
964
965 gfc_expr *
966 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
967 {
968 int kind;
969
970 if (x->ts.type == BT_INTEGER)
971 {
972 if (y->ts.type == BT_INTEGER)
973 kind = gfc_default_real_kind;
974 else
975 kind = y->ts.kind;
976 }
977 else
978 {
979 if (y->ts.type == BT_REAL)
980 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
981 else
982 kind = x->ts.kind;
983 }
984
985 if (x->expr_type != EXPR_CONSTANT
986 || (y != NULL && y->expr_type != EXPR_CONSTANT))
987 return only_convert_cmplx_boz (x, y, kind);
988
989 return simplify_cmplx ("COMPLEX", x, y, kind);
990 }
991
992
993 gfc_expr *
994 gfc_simplify_conjg (gfc_expr *e)
995 {
996 gfc_expr *result;
997
998 if (e->expr_type != EXPR_CONSTANT)
999 return NULL;
1000
1001 result = gfc_copy_expr (e);
1002 mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
1003
1004 return range_check (result, "CONJG");
1005 }
1006
1007
1008 gfc_expr *
1009 gfc_simplify_cos (gfc_expr *x)
1010 {
1011 gfc_expr *result;
1012 mpfr_t xp, xq;
1013
1014 if (x->expr_type != EXPR_CONSTANT)
1015 return NULL;
1016
1017 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1018
1019 switch (x->ts.type)
1020 {
1021 case BT_REAL:
1022 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1023 break;
1024 case BT_COMPLEX:
1025 gfc_set_model_kind (x->ts.kind);
1026 mpfr_init (xp);
1027 mpfr_init (xq);
1028
1029 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
1030 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
1031 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
1032
1033 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
1034 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
1035 mpfr_mul (xp, xp, xq, GFC_RND_MODE);
1036 mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
1037
1038 mpfr_clears (xp, xq, NULL);
1039 break;
1040 default:
1041 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1042 }
1043
1044 return range_check (result, "COS");
1045
1046 }
1047
1048
1049 gfc_expr *
1050 gfc_simplify_cosh (gfc_expr *x)
1051 {
1052 gfc_expr *result;
1053
1054 if (x->expr_type != EXPR_CONSTANT)
1055 return NULL;
1056
1057 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1058
1059 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1060
1061 return range_check (result, "COSH");
1062 }
1063
1064
1065 gfc_expr *
1066 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
1067 {
1068
1069 if (x->expr_type != EXPR_CONSTANT
1070 || (y != NULL && y->expr_type != EXPR_CONSTANT))
1071 return only_convert_cmplx_boz (x, y, gfc_default_double_kind);
1072
1073 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
1074 }
1075
1076
1077 gfc_expr *
1078 gfc_simplify_dble (gfc_expr *e)
1079 {
1080 gfc_expr *result = NULL;
1081
1082 if (e->expr_type != EXPR_CONSTANT)
1083 return NULL;
1084
1085 switch (e->ts.type)
1086 {
1087 case BT_INTEGER:
1088 if (!e->is_boz)
1089 result = gfc_int2real (e, gfc_default_double_kind);
1090 break;
1091
1092 case BT_REAL:
1093 result = gfc_real2real (e, gfc_default_double_kind);
1094 break;
1095
1096 case BT_COMPLEX:
1097 result = gfc_complex2real (e, gfc_default_double_kind);
1098 break;
1099
1100 default:
1101 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
1102 }
1103
1104 if (e->ts.type == BT_INTEGER && e->is_boz)
1105 {
1106 gfc_typespec ts;
1107 gfc_clear_ts (&ts);
1108 ts.type = BT_REAL;
1109 ts.kind = gfc_default_double_kind;
1110 result = gfc_copy_expr (e);
1111 if (!gfc_convert_boz (result, &ts))
1112 {
1113 gfc_free_expr (result);
1114 return &gfc_bad_expr;
1115 }
1116 }
1117
1118 return range_check (result, "DBLE");
1119 }
1120
1121
1122 gfc_expr *
1123 gfc_simplify_digits (gfc_expr *x)
1124 {
1125 int i, digits;
1126
1127 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1128 switch (x->ts.type)
1129 {
1130 case BT_INTEGER:
1131 digits = gfc_integer_kinds[i].digits;
1132 break;
1133
1134 case BT_REAL:
1135 case BT_COMPLEX:
1136 digits = gfc_real_kinds[i].digits;
1137 break;
1138
1139 default:
1140 gcc_unreachable ();
1141 }
1142
1143 return gfc_int_expr (digits);
1144 }
1145
1146
1147 gfc_expr *
1148 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1149 {
1150 gfc_expr *result;
1151 int kind;
1152
1153 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1154 return NULL;
1155
1156 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1157 result = gfc_constant_result (x->ts.type, kind, &x->where);
1158
1159 switch (x->ts.type)
1160 {
1161 case BT_INTEGER:
1162 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1163 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1164 else
1165 mpz_set_ui (result->value.integer, 0);
1166
1167 break;
1168
1169 case BT_REAL:
1170 if (mpfr_cmp (x->value.real, y->value.real) > 0)
1171 mpfr_sub (result->value.real, x->value.real, y->value.real,
1172 GFC_RND_MODE);
1173 else
1174 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1175
1176 break;
1177
1178 default:
1179 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1180 }
1181
1182 return range_check (result, "DIM");
1183 }
1184
1185
1186 gfc_expr *
1187 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1188 {
1189 gfc_expr *a1, *a2, *result;
1190
1191 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1192 return NULL;
1193
1194 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1195
1196 a1 = gfc_real2real (x, gfc_default_double_kind);
1197 a2 = gfc_real2real (y, gfc_default_double_kind);
1198
1199 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1200
1201 gfc_free_expr (a1);
1202 gfc_free_expr (a2);
1203
1204 return range_check (result, "DPROD");
1205 }
1206
1207
1208 gfc_expr *
1209 gfc_simplify_erf (gfc_expr *x)
1210 {
1211 gfc_expr *result;
1212
1213 if (x->expr_type != EXPR_CONSTANT)
1214 return NULL;
1215
1216 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1217
1218 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1219
1220 return range_check (result, "ERF");
1221 }
1222
1223
1224 gfc_expr *
1225 gfc_simplify_erfc (gfc_expr *x)
1226 {
1227 gfc_expr *result;
1228
1229 if (x->expr_type != EXPR_CONSTANT)
1230 return NULL;
1231
1232 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1233
1234 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1235
1236 return range_check (result, "ERFC");
1237 }
1238
1239
1240 gfc_expr *
1241 gfc_simplify_epsilon (gfc_expr *e)
1242 {
1243 gfc_expr *result;
1244 int i;
1245
1246 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1247
1248 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1249
1250 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1251
1252 return range_check (result, "EPSILON");
1253 }
1254
1255
1256 gfc_expr *
1257 gfc_simplify_exp (gfc_expr *x)
1258 {
1259 gfc_expr *result;
1260 mpfr_t xp, xq;
1261
1262 if (x->expr_type != EXPR_CONSTANT)
1263 return NULL;
1264
1265 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1266
1267 switch (x->ts.type)
1268 {
1269 case BT_REAL:
1270 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1271 break;
1272
1273 case BT_COMPLEX:
1274 gfc_set_model_kind (x->ts.kind);
1275 mpfr_init (xp);
1276 mpfr_init (xq);
1277 mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1278 mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1279 mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1280 mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1281 mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1282 mpfr_clears (xp, xq, NULL);
1283 break;
1284
1285 default:
1286 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1287 }
1288
1289 return range_check (result, "EXP");
1290 }
1291
1292 gfc_expr *
1293 gfc_simplify_exponent (gfc_expr *x)
1294 {
1295 int i;
1296 gfc_expr *result;
1297
1298 if (x->expr_type != EXPR_CONSTANT)
1299 return NULL;
1300
1301 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1302 &x->where);
1303
1304 gfc_set_model (x->value.real);
1305
1306 if (mpfr_sgn (x->value.real) == 0)
1307 {
1308 mpz_set_ui (result->value.integer, 0);
1309 return result;
1310 }
1311
1312 i = (int) mpfr_get_exp (x->value.real);
1313 mpz_set_si (result->value.integer, i);
1314
1315 return range_check (result, "EXPONENT");
1316 }
1317
1318
1319 gfc_expr *
1320 gfc_simplify_float (gfc_expr *a)
1321 {
1322 gfc_expr *result;
1323
1324 if (a->expr_type != EXPR_CONSTANT)
1325 return NULL;
1326
1327 if (a->is_boz)
1328 {
1329 gfc_typespec ts;
1330 gfc_clear_ts (&ts);
1331
1332 ts.type = BT_REAL;
1333 ts.kind = gfc_default_real_kind;
1334
1335 result = gfc_copy_expr (a);
1336 if (!gfc_convert_boz (result, &ts))
1337 {
1338 gfc_free_expr (result);
1339 return &gfc_bad_expr;
1340 }
1341 }
1342 else
1343 result = gfc_int2real (a, gfc_default_real_kind);
1344 return range_check (result, "FLOAT");
1345 }
1346
1347
1348 gfc_expr *
1349 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1350 {
1351 gfc_expr *result;
1352 mpfr_t floor;
1353 int kind;
1354
1355 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1356 if (kind == -1)
1357 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1358
1359 if (e->expr_type != EXPR_CONSTANT)
1360 return NULL;
1361
1362 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1363
1364 gfc_set_model_kind (kind);
1365 mpfr_init (floor);
1366 mpfr_floor (floor, e->value.real);
1367
1368 gfc_mpfr_to_mpz (result->value.integer, floor);
1369
1370 mpfr_clear (floor);
1371
1372 return range_check (result, "FLOOR");
1373 }
1374
1375
1376 gfc_expr *
1377 gfc_simplify_fraction (gfc_expr *x)
1378 {
1379 gfc_expr *result;
1380 mpfr_t absv, exp, pow2;
1381
1382 if (x->expr_type != EXPR_CONSTANT)
1383 return NULL;
1384
1385 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1386
1387 if (mpfr_sgn (x->value.real) == 0)
1388 {
1389 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1390 return result;
1391 }
1392
1393 gfc_set_model_kind (x->ts.kind);
1394 mpfr_init (exp);
1395 mpfr_init (absv);
1396 mpfr_init (pow2);
1397
1398 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1399 mpfr_log2 (exp, absv, GFC_RND_MODE);
1400
1401 mpfr_trunc (exp, exp);
1402 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1403
1404 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1405
1406 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1407
1408 mpfr_clears (exp, absv, pow2, NULL);
1409
1410 return range_check (result, "FRACTION");
1411 }
1412
1413
1414 gfc_expr *
1415 gfc_simplify_gamma (gfc_expr *x)
1416 {
1417 gfc_expr *result;
1418
1419 if (x->expr_type != EXPR_CONSTANT)
1420 return NULL;
1421
1422 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1423
1424 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1425
1426 return range_check (result, "GAMMA");
1427 }
1428
1429
1430 gfc_expr *
1431 gfc_simplify_huge (gfc_expr *e)
1432 {
1433 gfc_expr *result;
1434 int i;
1435
1436 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1437
1438 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1439
1440 switch (e->ts.type)
1441 {
1442 case BT_INTEGER:
1443 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1444 break;
1445
1446 case BT_REAL:
1447 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1448 break;
1449
1450 default:
1451 gcc_unreachable ();
1452 }
1453
1454 return result;
1455 }
1456
1457
1458 gfc_expr *
1459 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
1460 {
1461 gfc_expr *result;
1462
1463 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1464 return NULL;
1465
1466 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1467 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
1468 return range_check (result, "HYPOT");
1469 }
1470
1471
1472 /* We use the processor's collating sequence, because all
1473 systems that gfortran currently works on are ASCII. */
1474
1475 gfc_expr *
1476 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
1477 {
1478 gfc_expr *result;
1479 gfc_char_t index;
1480
1481 if (e->expr_type != EXPR_CONSTANT)
1482 return NULL;
1483
1484 if (e->value.character.length != 1)
1485 {
1486 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1487 return &gfc_bad_expr;
1488 }
1489
1490 index = e->value.character.string[0];
1491
1492 if (gfc_option.warn_surprising && index > 127)
1493 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1494 &e->where);
1495
1496 if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
1497 return &gfc_bad_expr;
1498
1499 result->where = e->where;
1500
1501 return range_check (result, "IACHAR");
1502 }
1503
1504
1505 gfc_expr *
1506 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1507 {
1508 gfc_expr *result;
1509
1510 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1511 return NULL;
1512
1513 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1514
1515 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1516
1517 return range_check (result, "IAND");
1518 }
1519
1520
1521 gfc_expr *
1522 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1523 {
1524 gfc_expr *result;
1525 int k, pos;
1526
1527 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1528 return NULL;
1529
1530 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1531 {
1532 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1533 return &gfc_bad_expr;
1534 }
1535
1536 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1537
1538 if (pos >= gfc_integer_kinds[k].bit_size)
1539 {
1540 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1541 &y->where);
1542 return &gfc_bad_expr;
1543 }
1544
1545 result = gfc_copy_expr (x);
1546
1547 convert_mpz_to_unsigned (result->value.integer,
1548 gfc_integer_kinds[k].bit_size);
1549
1550 mpz_clrbit (result->value.integer, pos);
1551
1552 convert_mpz_to_signed (result->value.integer,
1553 gfc_integer_kinds[k].bit_size);
1554
1555 return result;
1556 }
1557
1558
1559 gfc_expr *
1560 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1561 {
1562 gfc_expr *result;
1563 int pos, len;
1564 int i, k, bitsize;
1565 int *bits;
1566
1567 if (x->expr_type != EXPR_CONSTANT
1568 || y->expr_type != EXPR_CONSTANT
1569 || z->expr_type != EXPR_CONSTANT)
1570 return NULL;
1571
1572 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1573 {
1574 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1575 return &gfc_bad_expr;
1576 }
1577
1578 if (gfc_extract_int (z, &len) != NULL || len < 0)
1579 {
1580 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1581 return &gfc_bad_expr;
1582 }
1583
1584 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1585
1586 bitsize = gfc_integer_kinds[k].bit_size;
1587
1588 if (pos + len > bitsize)
1589 {
1590 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1591 "bit size at %L", &y->where);
1592 return &gfc_bad_expr;
1593 }
1594
1595 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1596 convert_mpz_to_unsigned (result->value.integer,
1597 gfc_integer_kinds[k].bit_size);
1598
1599 bits = XCNEWVEC (int, bitsize);
1600
1601 for (i = 0; i < bitsize; i++)
1602 bits[i] = 0;
1603
1604 for (i = 0; i < len; i++)
1605 bits[i] = mpz_tstbit (x->value.integer, i + pos);
1606
1607 for (i = 0; i < bitsize; i++)
1608 {
1609 if (bits[i] == 0)
1610 mpz_clrbit (result->value.integer, i);
1611 else if (bits[i] == 1)
1612 mpz_setbit (result->value.integer, i);
1613 else
1614 gfc_internal_error ("IBITS: Bad bit");
1615 }
1616
1617 gfc_free (bits);
1618
1619 convert_mpz_to_signed (result->value.integer,
1620 gfc_integer_kinds[k].bit_size);
1621
1622 return result;
1623 }
1624
1625
1626 gfc_expr *
1627 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1628 {
1629 gfc_expr *result;
1630 int k, pos;
1631
1632 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1633 return NULL;
1634
1635 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1636 {
1637 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1638 return &gfc_bad_expr;
1639 }
1640
1641 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1642
1643 if (pos >= gfc_integer_kinds[k].bit_size)
1644 {
1645 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1646 &y->where);
1647 return &gfc_bad_expr;
1648 }
1649
1650 result = gfc_copy_expr (x);
1651
1652 convert_mpz_to_unsigned (result->value.integer,
1653 gfc_integer_kinds[k].bit_size);
1654
1655 mpz_setbit (result->value.integer, pos);
1656
1657 convert_mpz_to_signed (result->value.integer,
1658 gfc_integer_kinds[k].bit_size);
1659
1660 return result;
1661 }
1662
1663
1664 gfc_expr *
1665 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
1666 {
1667 gfc_expr *result;
1668 gfc_char_t index;
1669
1670 if (e->expr_type != EXPR_CONSTANT)
1671 return NULL;
1672
1673 if (e->value.character.length != 1)
1674 {
1675 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1676 return &gfc_bad_expr;
1677 }
1678
1679 index = e->value.character.string[0];
1680
1681 if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
1682 return &gfc_bad_expr;
1683
1684 result->where = e->where;
1685 return range_check (result, "ICHAR");
1686 }
1687
1688
1689 gfc_expr *
1690 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
1691 {
1692 gfc_expr *result;
1693
1694 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1695 return NULL;
1696
1697 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1698
1699 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
1700
1701 return range_check (result, "IEOR");
1702 }
1703
1704
1705 gfc_expr *
1706 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
1707 {
1708 gfc_expr *result;
1709 int back, len, lensub;
1710 int i, j, k, count, index = 0, start;
1711
1712 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
1713 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
1714 return NULL;
1715
1716 if (b != NULL && b->value.logical != 0)
1717 back = 1;
1718 else
1719 back = 0;
1720
1721 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
1722 if (k == -1)
1723 return &gfc_bad_expr;
1724
1725 result = gfc_constant_result (BT_INTEGER, k, &x->where);
1726
1727 len = x->value.character.length;
1728 lensub = y->value.character.length;
1729
1730 if (len < lensub)
1731 {
1732 mpz_set_si (result->value.integer, 0);
1733 return result;
1734 }
1735
1736 if (back == 0)
1737 {
1738 if (lensub == 0)
1739 {
1740 mpz_set_si (result->value.integer, 1);
1741 return result;
1742 }
1743 else if (lensub == 1)
1744 {
1745 for (i = 0; i < len; i++)
1746 {
1747 for (j = 0; j < lensub; j++)
1748 {
1749 if (y->value.character.string[j]
1750 == x->value.character.string[i])
1751 {
1752 index = i + 1;
1753 goto done;
1754 }
1755 }
1756 }
1757 }
1758 else
1759 {
1760 for (i = 0; i < len; i++)
1761 {
1762 for (j = 0; j < lensub; j++)
1763 {
1764 if (y->value.character.string[j]
1765 == x->value.character.string[i])
1766 {
1767 start = i;
1768 count = 0;
1769
1770 for (k = 0; k < lensub; k++)
1771 {
1772 if (y->value.character.string[k]
1773 == x->value.character.string[k + start])
1774 count++;
1775 }
1776
1777 if (count == lensub)
1778 {
1779 index = start + 1;
1780 goto done;
1781 }
1782 }
1783 }
1784 }
1785 }
1786
1787 }
1788 else
1789 {
1790 if (lensub == 0)
1791 {
1792 mpz_set_si (result->value.integer, len + 1);
1793 return result;
1794 }
1795 else if (lensub == 1)
1796 {
1797 for (i = 0; i < len; i++)
1798 {
1799 for (j = 0; j < lensub; j++)
1800 {
1801 if (y->value.character.string[j]
1802 == x->value.character.string[len - i])
1803 {
1804 index = len - i + 1;
1805 goto done;
1806 }
1807 }
1808 }
1809 }
1810 else
1811 {
1812 for (i = 0; i < len; i++)
1813 {
1814 for (j = 0; j < lensub; j++)
1815 {
1816 if (y->value.character.string[j]
1817 == x->value.character.string[len - i])
1818 {
1819 start = len - i;
1820 if (start <= len - lensub)
1821 {
1822 count = 0;
1823 for (k = 0; k < lensub; k++)
1824 if (y->value.character.string[k]
1825 == x->value.character.string[k + start])
1826 count++;
1827
1828 if (count == lensub)
1829 {
1830 index = start + 1;
1831 goto done;
1832 }
1833 }
1834 else
1835 {
1836 continue;
1837 }
1838 }
1839 }
1840 }
1841 }
1842 }
1843
1844 done:
1845 mpz_set_si (result->value.integer, index);
1846 return range_check (result, "INDEX");
1847 }
1848
1849
1850 gfc_expr *
1851 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
1852 {
1853 gfc_expr *result = NULL;
1854 int kind;
1855
1856 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
1857 if (kind == -1)
1858 return &gfc_bad_expr;
1859
1860 if (e->expr_type != EXPR_CONSTANT)
1861 return NULL;
1862
1863 switch (e->ts.type)
1864 {
1865 case BT_INTEGER:
1866 result = gfc_int2int (e, kind);
1867 break;
1868
1869 case BT_REAL:
1870 result = gfc_real2int (e, kind);
1871 break;
1872
1873 case BT_COMPLEX:
1874 result = gfc_complex2int (e, kind);
1875 break;
1876
1877 default:
1878 gfc_error ("Argument of INT at %L is not a valid type", &e->where);
1879 return &gfc_bad_expr;
1880 }
1881
1882 return range_check (result, "INT");
1883 }
1884
1885
1886 static gfc_expr *
1887 simplify_intconv (gfc_expr *e, int kind, const char *name)
1888 {
1889 gfc_expr *result = NULL;
1890
1891 if (e->expr_type != EXPR_CONSTANT)
1892 return NULL;
1893
1894 switch (e->ts.type)
1895 {
1896 case BT_INTEGER:
1897 result = gfc_int2int (e, kind);
1898 break;
1899
1900 case BT_REAL:
1901 result = gfc_real2int (e, kind);
1902 break;
1903
1904 case BT_COMPLEX:
1905 result = gfc_complex2int (e, kind);
1906 break;
1907
1908 default:
1909 gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
1910 return &gfc_bad_expr;
1911 }
1912
1913 return range_check (result, name);
1914 }
1915
1916
1917 gfc_expr *
1918 gfc_simplify_int2 (gfc_expr *e)
1919 {
1920 return simplify_intconv (e, 2, "INT2");
1921 }
1922
1923
1924 gfc_expr *
1925 gfc_simplify_int8 (gfc_expr *e)
1926 {
1927 return simplify_intconv (e, 8, "INT8");
1928 }
1929
1930
1931 gfc_expr *
1932 gfc_simplify_long (gfc_expr *e)
1933 {
1934 return simplify_intconv (e, 4, "LONG");
1935 }
1936
1937
1938 gfc_expr *
1939 gfc_simplify_ifix (gfc_expr *e)
1940 {
1941 gfc_expr *rtrunc, *result;
1942
1943 if (e->expr_type != EXPR_CONSTANT)
1944 return NULL;
1945
1946 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1947 &e->where);
1948
1949 rtrunc = gfc_copy_expr (e);
1950
1951 mpfr_trunc (rtrunc->value.real, e->value.real);
1952 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1953
1954 gfc_free_expr (rtrunc);
1955 return range_check (result, "IFIX");
1956 }
1957
1958
1959 gfc_expr *
1960 gfc_simplify_idint (gfc_expr *e)
1961 {
1962 gfc_expr *rtrunc, *result;
1963
1964 if (e->expr_type != EXPR_CONSTANT)
1965 return NULL;
1966
1967 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1968 &e->where);
1969
1970 rtrunc = gfc_copy_expr (e);
1971
1972 mpfr_trunc (rtrunc->value.real, e->value.real);
1973 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
1974
1975 gfc_free_expr (rtrunc);
1976 return range_check (result, "IDINT");
1977 }
1978
1979
1980 gfc_expr *
1981 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
1982 {
1983 gfc_expr *result;
1984
1985 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1986 return NULL;
1987
1988 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1989
1990 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
1991 return range_check (result, "IOR");
1992 }
1993
1994
1995 gfc_expr *
1996 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
1997 {
1998 gfc_expr *result;
1999 int shift, ashift, isize, k, *bits, i;
2000
2001 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2002 return NULL;
2003
2004 if (gfc_extract_int (s, &shift) != NULL)
2005 {
2006 gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
2007 return &gfc_bad_expr;
2008 }
2009
2010 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
2011
2012 isize = gfc_integer_kinds[k].bit_size;
2013
2014 if (shift >= 0)
2015 ashift = shift;
2016 else
2017 ashift = -shift;
2018
2019 if (ashift > isize)
2020 {
2021 gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
2022 "at %L", &s->where);
2023 return &gfc_bad_expr;
2024 }
2025
2026 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2027
2028 if (shift == 0)
2029 {
2030 mpz_set (result->value.integer, e->value.integer);
2031 return range_check (result, "ISHFT");
2032 }
2033
2034 bits = XCNEWVEC (int, isize);
2035
2036 for (i = 0; i < isize; i++)
2037 bits[i] = mpz_tstbit (e->value.integer, i);
2038
2039 if (shift > 0)
2040 {
2041 for (i = 0; i < shift; i++)
2042 mpz_clrbit (result->value.integer, i);
2043
2044 for (i = 0; i < isize - shift; i++)
2045 {
2046 if (bits[i] == 0)
2047 mpz_clrbit (result->value.integer, i + shift);
2048 else
2049 mpz_setbit (result->value.integer, i + shift);
2050 }
2051 }
2052 else
2053 {
2054 for (i = isize - 1; i >= isize - ashift; i--)
2055 mpz_clrbit (result->value.integer, i);
2056
2057 for (i = isize - 1; i >= ashift; i--)
2058 {
2059 if (bits[i] == 0)
2060 mpz_clrbit (result->value.integer, i - ashift);
2061 else
2062 mpz_setbit (result->value.integer, i - ashift);
2063 }
2064 }
2065
2066 convert_mpz_to_signed (result->value.integer, isize);
2067
2068 gfc_free (bits);
2069 return result;
2070 }
2071
2072
2073 gfc_expr *
2074 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
2075 {
2076 gfc_expr *result;
2077 int shift, ashift, isize, ssize, delta, k;
2078 int i, *bits;
2079
2080 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2081 return NULL;
2082
2083 if (gfc_extract_int (s, &shift) != NULL)
2084 {
2085 gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
2086 return &gfc_bad_expr;
2087 }
2088
2089 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2090 isize = gfc_integer_kinds[k].bit_size;
2091
2092 if (sz != NULL)
2093 {
2094 if (sz->expr_type != EXPR_CONSTANT)
2095 return NULL;
2096
2097 if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
2098 {
2099 gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
2100 return &gfc_bad_expr;
2101 }
2102
2103 if (ssize > isize)
2104 {
2105 gfc_error ("Magnitude of third argument of ISHFTC exceeds "
2106 "BIT_SIZE of first argument at %L", &s->where);
2107 return &gfc_bad_expr;
2108 }
2109 }
2110 else
2111 ssize = isize;
2112
2113 if (shift >= 0)
2114 ashift = shift;
2115 else
2116 ashift = -shift;
2117
2118 if (ashift > ssize)
2119 {
2120 if (sz != NULL)
2121 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2122 "third argument at %L", &s->where);
2123 else
2124 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
2125 "BIT_SIZE of first argument at %L", &s->where);
2126 return &gfc_bad_expr;
2127 }
2128
2129 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
2130
2131 mpz_set (result->value.integer, e->value.integer);
2132
2133 if (shift == 0)
2134 return result;
2135
2136 convert_mpz_to_unsigned (result->value.integer, isize);
2137
2138 bits = XCNEWVEC (int, ssize);
2139
2140 for (i = 0; i < ssize; i++)
2141 bits[i] = mpz_tstbit (e->value.integer, i);
2142
2143 delta = ssize - ashift;
2144
2145 if (shift > 0)
2146 {
2147 for (i = 0; i < delta; i++)
2148 {
2149 if (bits[i] == 0)
2150 mpz_clrbit (result->value.integer, i + shift);
2151 else
2152 mpz_setbit (result->value.integer, i + shift);
2153 }
2154
2155 for (i = delta; i < ssize; i++)
2156 {
2157 if (bits[i] == 0)
2158 mpz_clrbit (result->value.integer, i - delta);
2159 else
2160 mpz_setbit (result->value.integer, i - delta);
2161 }
2162 }
2163 else
2164 {
2165 for (i = 0; i < ashift; i++)
2166 {
2167 if (bits[i] == 0)
2168 mpz_clrbit (result->value.integer, i + delta);
2169 else
2170 mpz_setbit (result->value.integer, i + delta);
2171 }
2172
2173 for (i = ashift; i < ssize; i++)
2174 {
2175 if (bits[i] == 0)
2176 mpz_clrbit (result->value.integer, i + shift);
2177 else
2178 mpz_setbit (result->value.integer, i + shift);
2179 }
2180 }
2181
2182 convert_mpz_to_signed (result->value.integer, isize);
2183
2184 gfc_free (bits);
2185 return result;
2186 }
2187
2188
2189 gfc_expr *
2190 gfc_simplify_kind (gfc_expr *e)
2191 {
2192
2193 if (e->ts.type == BT_DERIVED)
2194 {
2195 gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
2196 return &gfc_bad_expr;
2197 }
2198
2199 return gfc_int_expr (e->ts.kind);
2200 }
2201
2202
2203 static gfc_expr *
2204 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
2205 gfc_array_spec *as)
2206 {
2207 gfc_expr *l, *u, *result;
2208 int k;
2209
2210 /* The last dimension of an assumed-size array is special. */
2211 if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
2212 {
2213 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
2214 return gfc_copy_expr (as->lower[d-1]);
2215 else
2216 return NULL;
2217 }
2218
2219 /* Then, we need to know the extent of the given dimension. */
2220 l = as->lower[d-1];
2221 u = as->upper[d-1];
2222
2223 if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
2224 return NULL;
2225
2226 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2227 gfc_default_integer_kind);
2228 if (k == -1)
2229 return &gfc_bad_expr;
2230
2231 result = gfc_constant_result (BT_INTEGER, k, &array->where);
2232
2233 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
2234 {
2235 /* Zero extent. */
2236 if (upper)
2237 mpz_set_si (result->value.integer, 0);
2238 else
2239 mpz_set_si (result->value.integer, 1);
2240 }
2241 else
2242 {
2243 /* Nonzero extent. */
2244 if (upper)
2245 mpz_set (result->value.integer, u->value.integer);
2246 else
2247 mpz_set (result->value.integer, l->value.integer);
2248 }
2249
2250 return range_check (result, upper ? "UBOUND" : "LBOUND");
2251 }
2252
2253
2254 static gfc_expr *
2255 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
2256 {
2257 gfc_ref *ref;
2258 gfc_array_spec *as;
2259 int d;
2260
2261 if (array->expr_type != EXPR_VARIABLE)
2262 return NULL;
2263
2264 /* Follow any component references. */
2265 as = array->symtree->n.sym->as;
2266 for (ref = array->ref; ref; ref = ref->next)
2267 {
2268 switch (ref->type)
2269 {
2270 case REF_ARRAY:
2271 switch (ref->u.ar.type)
2272 {
2273 case AR_ELEMENT:
2274 as = NULL;
2275 continue;
2276
2277 case AR_FULL:
2278 /* We're done because 'as' has already been set in the
2279 previous iteration. */
2280 goto done;
2281
2282 case AR_SECTION:
2283 case AR_UNKNOWN:
2284 return NULL;
2285 }
2286
2287 gcc_unreachable ();
2288
2289 case REF_COMPONENT:
2290 as = ref->u.c.component->as;
2291 continue;
2292
2293 case REF_SUBSTRING:
2294 continue;
2295 }
2296 }
2297
2298 gcc_unreachable ();
2299
2300 done:
2301
2302 if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
2303 return NULL;
2304
2305 if (dim == NULL)
2306 {
2307 /* Multi-dimensional bounds. */
2308 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
2309 gfc_expr *e;
2310 gfc_constructor *head, *tail;
2311 int k;
2312
2313 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
2314 if (upper && as->type == AS_ASSUMED_SIZE)
2315 {
2316 /* An error message will be emitted in
2317 check_assumed_size_reference (resolve.c). */
2318 return &gfc_bad_expr;
2319 }
2320
2321 /* Simplify the bounds for each dimension. */
2322 for (d = 0; d < array->rank; d++)
2323 {
2324 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
2325 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
2326 {
2327 int j;
2328
2329 for (j = 0; j < d; j++)
2330 gfc_free_expr (bounds[j]);
2331 return bounds[d];
2332 }
2333 }
2334
2335 /* Allocate the result expression. */
2336 e = gfc_get_expr ();
2337 e->where = array->where;
2338 e->expr_type = EXPR_ARRAY;
2339 e->ts.type = BT_INTEGER;
2340 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
2341 gfc_default_integer_kind);
2342 if (k == -1)
2343 {
2344 gfc_free_expr (e);
2345 return &gfc_bad_expr;
2346 }
2347 e->ts.kind = k;
2348
2349 /* The result is a rank 1 array; its size is the rank of the first
2350 argument to {L,U}BOUND. */
2351 e->rank = 1;
2352 e->shape = gfc_get_shape (1);
2353 mpz_init_set_ui (e->shape[0], array->rank);
2354
2355 /* Create the constructor for this array. */
2356 head = tail = NULL;
2357 for (d = 0; d < array->rank; d++)
2358 {
2359 /* Get a new constructor element. */
2360 if (head == NULL)
2361 head = tail = gfc_get_constructor ();
2362 else
2363 {
2364 tail->next = gfc_get_constructor ();
2365 tail = tail->next;
2366 }
2367
2368 tail->where = e->where;
2369 tail->expr = bounds[d];
2370 }
2371 e->value.constructor = head;
2372
2373 return e;
2374 }
2375 else
2376 {
2377 /* A DIM argument is specified. */
2378 if (dim->expr_type != EXPR_CONSTANT)
2379 return NULL;
2380
2381 d = mpz_get_si (dim->value.integer);
2382
2383 if (d < 1 || d > as->rank
2384 || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
2385 {
2386 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
2387 return &gfc_bad_expr;
2388 }
2389
2390 return simplify_bound_dim (array, kind, d, upper, as);
2391 }
2392 }
2393
2394
2395 gfc_expr *
2396 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
2397 {
2398 return simplify_bound (array, dim, kind, 0);
2399 }
2400
2401
2402 gfc_expr *
2403 gfc_simplify_leadz (gfc_expr *e)
2404 {
2405 gfc_expr *result;
2406 unsigned long lz, bs;
2407 int i;
2408
2409 if (e->expr_type != EXPR_CONSTANT)
2410 return NULL;
2411
2412 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2413 bs = gfc_integer_kinds[i].bit_size;
2414 if (mpz_cmp_si (e->value.integer, 0) == 0)
2415 lz = bs;
2416 else
2417 lz = bs - mpz_sizeinbase (e->value.integer, 2);
2418
2419 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
2420 mpz_set_ui (result->value.integer, lz);
2421
2422 return result;
2423 }
2424
2425
2426 gfc_expr *
2427 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
2428 {
2429 gfc_expr *result;
2430 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
2431
2432 if (k == -1)
2433 return &gfc_bad_expr;
2434
2435 if (e->expr_type == EXPR_CONSTANT)
2436 {
2437 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2438 mpz_set_si (result->value.integer, e->value.character.length);
2439 return range_check (result, "LEN");
2440 }
2441
2442 if (e->ts.cl != NULL && e->ts.cl->length != NULL
2443 && e->ts.cl->length->expr_type == EXPR_CONSTANT
2444 && e->ts.cl->length->ts.type == BT_INTEGER)
2445 {
2446 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2447 mpz_set (result->value.integer, e->ts.cl->length->value.integer);
2448 return range_check (result, "LEN");
2449 }
2450
2451 return NULL;
2452 }
2453
2454
2455 gfc_expr *
2456 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
2457 {
2458 gfc_expr *result;
2459 int count, len, lentrim, i;
2460 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
2461
2462 if (k == -1)
2463 return &gfc_bad_expr;
2464
2465 if (e->expr_type != EXPR_CONSTANT)
2466 return NULL;
2467
2468 result = gfc_constant_result (BT_INTEGER, k, &e->where);
2469 len = e->value.character.length;
2470
2471 for (count = 0, i = 1; i <= len; i++)
2472 if (e->value.character.string[len - i] == ' ')
2473 count++;
2474 else
2475 break;
2476
2477 lentrim = len - count;
2478
2479 mpz_set_si (result->value.integer, lentrim);
2480 return range_check (result, "LEN_TRIM");
2481 }
2482
2483 gfc_expr *
2484 gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED)
2485 {
2486 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
2487 gfc_expr *result;
2488 int sg;
2489
2490 if (x->expr_type != EXPR_CONSTANT)
2491 return NULL;
2492
2493 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2494
2495 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
2496
2497 return range_check (result, "LGAMMA");
2498 #else
2499 return NULL;
2500 #endif
2501 }
2502
2503
2504 gfc_expr *
2505 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
2506 {
2507 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2508 return NULL;
2509
2510 return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
2511 }
2512
2513
2514 gfc_expr *
2515 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
2516 {
2517 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2518 return NULL;
2519
2520 return gfc_logical_expr (gfc_compare_string (a, b) > 0,
2521 &a->where);
2522 }
2523
2524
2525 gfc_expr *
2526 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
2527 {
2528 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2529 return NULL;
2530
2531 return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
2532 }
2533
2534
2535 gfc_expr *
2536 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
2537 {
2538 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
2539 return NULL;
2540
2541 return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
2542 }
2543
2544
2545 gfc_expr *
2546 gfc_simplify_log (gfc_expr *x)
2547 {
2548 gfc_expr *result;
2549 mpfr_t xr, xi;
2550
2551 if (x->expr_type != EXPR_CONSTANT)
2552 return NULL;
2553
2554 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2555
2556
2557 switch (x->ts.type)
2558 {
2559 case BT_REAL:
2560 if (mpfr_sgn (x->value.real) <= 0)
2561 {
2562 gfc_error ("Argument of LOG at %L cannot be less than or equal "
2563 "to zero", &x->where);
2564 gfc_free_expr (result);
2565 return &gfc_bad_expr;
2566 }
2567
2568 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
2569 break;
2570
2571 case BT_COMPLEX:
2572 if ((mpfr_sgn (x->value.complex.r) == 0)
2573 && (mpfr_sgn (x->value.complex.i) == 0))
2574 {
2575 gfc_error ("Complex argument of LOG at %L cannot be zero",
2576 &x->where);
2577 gfc_free_expr (result);
2578 return &gfc_bad_expr;
2579 }
2580
2581 gfc_set_model_kind (x->ts.kind);
2582 mpfr_init (xr);
2583 mpfr_init (xi);
2584
2585 mpfr_atan2 (result->value.complex.i, x->value.complex.i,
2586 x->value.complex.r, GFC_RND_MODE);
2587
2588 mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
2589 mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
2590 mpfr_add (xr, xr, xi, GFC_RND_MODE);
2591 mpfr_sqrt (xr, xr, GFC_RND_MODE);
2592 mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
2593
2594 mpfr_clears (xr, xi, NULL);
2595
2596 break;
2597
2598 default:
2599 gfc_internal_error ("gfc_simplify_log: bad type");
2600 }
2601
2602 return range_check (result, "LOG");
2603 }
2604
2605
2606 gfc_expr *
2607 gfc_simplify_log10 (gfc_expr *x)
2608 {
2609 gfc_expr *result;
2610
2611 if (x->expr_type != EXPR_CONSTANT)
2612 return NULL;
2613
2614 if (mpfr_sgn (x->value.real) <= 0)
2615 {
2616 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
2617 "to zero", &x->where);
2618 return &gfc_bad_expr;
2619 }
2620
2621 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
2622
2623 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
2624
2625 return range_check (result, "LOG10");
2626 }
2627
2628
2629 gfc_expr *
2630 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
2631 {
2632 gfc_expr *result;
2633 int kind;
2634
2635 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
2636 if (kind < 0)
2637 return &gfc_bad_expr;
2638
2639 if (e->expr_type != EXPR_CONSTANT)
2640 return NULL;
2641
2642 result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
2643
2644 result->value.logical = e->value.logical;
2645
2646 return result;
2647 }
2648
2649
2650 /* This function is special since MAX() can take any number of
2651 arguments. The simplified expression is a rewritten version of the
2652 argument list containing at most one constant element. Other
2653 constant elements are deleted. Because the argument list has
2654 already been checked, this function always succeeds. sign is 1 for
2655 MAX(), -1 for MIN(). */
2656
2657 static gfc_expr *
2658 simplify_min_max (gfc_expr *expr, int sign)
2659 {
2660 gfc_actual_arglist *arg, *last, *extremum;
2661 gfc_intrinsic_sym * specific;
2662
2663 last = NULL;
2664 extremum = NULL;
2665 specific = expr->value.function.isym;
2666
2667 arg = expr->value.function.actual;
2668
2669 for (; arg; last = arg, arg = arg->next)
2670 {
2671 if (arg->expr->expr_type != EXPR_CONSTANT)
2672 continue;
2673
2674 if (extremum == NULL)
2675 {
2676 extremum = arg;
2677 continue;
2678 }
2679
2680 switch (arg->expr->ts.type)
2681 {
2682 case BT_INTEGER:
2683 if (mpz_cmp (arg->expr->value.integer,
2684 extremum->expr->value.integer) * sign > 0)
2685 mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
2686 break;
2687
2688 case BT_REAL:
2689 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
2690 if (sign > 0)
2691 mpfr_max (extremum->expr->value.real, extremum->expr->value.real,
2692 arg->expr->value.real, GFC_RND_MODE);
2693 else
2694 mpfr_min (extremum->expr->value.real, extremum->expr->value.real,
2695 arg->expr->value.real, GFC_RND_MODE);
2696 break;
2697
2698 case BT_CHARACTER:
2699 #define LENGTH(x) ((x)->expr->value.character.length)
2700 #define STRING(x) ((x)->expr->value.character.string)
2701 if (LENGTH(extremum) < LENGTH(arg))
2702 {
2703 gfc_char_t *tmp = STRING(extremum);
2704
2705 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
2706 memcpy (STRING(extremum), tmp,
2707 LENGTH(extremum) * sizeof (gfc_char_t));
2708 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
2709 LENGTH(arg) - LENGTH(extremum));
2710 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
2711 LENGTH(extremum) = LENGTH(arg);
2712 gfc_free (tmp);
2713 }
2714
2715 if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
2716 {
2717 gfc_free (STRING(extremum));
2718 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
2719 memcpy (STRING(extremum), STRING(arg),
2720 LENGTH(arg) * sizeof (gfc_char_t));
2721 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
2722 LENGTH(extremum) - LENGTH(arg));
2723 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
2724 }
2725 #undef LENGTH
2726 #undef STRING
2727 break;
2728
2729
2730 default:
2731 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
2732 }
2733
2734 /* Delete the extra constant argument. */
2735 if (last == NULL)
2736 expr->value.function.actual = arg->next;
2737 else
2738 last->next = arg->next;
2739
2740 arg->next = NULL;
2741 gfc_free_actual_arglist (arg);
2742 arg = last;
2743 }
2744
2745 /* If there is one value left, replace the function call with the
2746 expression. */
2747 if (expr->value.function.actual->next != NULL)
2748 return NULL;
2749
2750 /* Convert to the correct type and kind. */
2751 if (expr->ts.type != BT_UNKNOWN)
2752 return gfc_convert_constant (expr->value.function.actual->expr,
2753 expr->ts.type, expr->ts.kind);
2754
2755 if (specific->ts.type != BT_UNKNOWN)
2756 return gfc_convert_constant (expr->value.function.actual->expr,
2757 specific->ts.type, specific->ts.kind);
2758
2759 return gfc_copy_expr (expr->value.function.actual->expr);
2760 }
2761
2762
2763 gfc_expr *
2764 gfc_simplify_min (gfc_expr *e)
2765 {
2766 return simplify_min_max (e, -1);
2767 }
2768
2769
2770 gfc_expr *
2771 gfc_simplify_max (gfc_expr *e)
2772 {
2773 return simplify_min_max (e, 1);
2774 }
2775
2776
2777 gfc_expr *
2778 gfc_simplify_maxexponent (gfc_expr *x)
2779 {
2780 gfc_expr *result;
2781 int i;
2782
2783 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2784
2785 result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
2786 result->where = x->where;
2787
2788 return result;
2789 }
2790
2791
2792 gfc_expr *
2793 gfc_simplify_minexponent (gfc_expr *x)
2794 {
2795 gfc_expr *result;
2796 int i;
2797
2798 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
2799
2800 result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
2801 result->where = x->where;
2802
2803 return result;
2804 }
2805
2806
2807 gfc_expr *
2808 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
2809 {
2810 gfc_expr *result;
2811 mpfr_t tmp;
2812 int kind;
2813
2814 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2815 return NULL;
2816
2817 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2818 result = gfc_constant_result (a->ts.type, kind, &a->where);
2819
2820 switch (a->ts.type)
2821 {
2822 case BT_INTEGER:
2823 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2824 {
2825 /* Result is processor-dependent. */
2826 gfc_error ("Second argument MOD at %L is zero", &a->where);
2827 gfc_free_expr (result);
2828 return &gfc_bad_expr;
2829 }
2830 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
2831 break;
2832
2833 case BT_REAL:
2834 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2835 {
2836 /* Result is processor-dependent. */
2837 gfc_error ("Second argument of MOD at %L is zero", &p->where);
2838 gfc_free_expr (result);
2839 return &gfc_bad_expr;
2840 }
2841
2842 gfc_set_model_kind (kind);
2843 mpfr_init (tmp);
2844 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
2845 mpfr_trunc (tmp, tmp);
2846 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
2847 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
2848 mpfr_clear (tmp);
2849 break;
2850
2851 default:
2852 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
2853 }
2854
2855 return range_check (result, "MOD");
2856 }
2857
2858
2859 gfc_expr *
2860 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
2861 {
2862 gfc_expr *result;
2863 mpfr_t tmp;
2864 int kind;
2865
2866 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
2867 return NULL;
2868
2869 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
2870 result = gfc_constant_result (a->ts.type, kind, &a->where);
2871
2872 switch (a->ts.type)
2873 {
2874 case BT_INTEGER:
2875 if (mpz_cmp_ui (p->value.integer, 0) == 0)
2876 {
2877 /* Result is processor-dependent. This processor just opts
2878 to not handle it at all. */
2879 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
2880 gfc_free_expr (result);
2881 return &gfc_bad_expr;
2882 }
2883 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
2884
2885 break;
2886
2887 case BT_REAL:
2888 if (mpfr_cmp_ui (p->value.real, 0) == 0)
2889 {
2890 /* Result is processor-dependent. */
2891 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
2892 gfc_free_expr (result);
2893 return &gfc_bad_expr;
2894 }
2895
2896 gfc_set_model_kind (kind);
2897 mpfr_init (tmp);
2898 mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
2899 mpfr_floor (tmp, tmp);
2900 mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
2901 mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
2902 mpfr_clear (tmp);
2903 break;
2904
2905 default:
2906 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
2907 }
2908
2909 return range_check (result, "MODULO");
2910 }
2911
2912
2913 /* Exists for the sole purpose of consistency with other intrinsics. */
2914 gfc_expr *
2915 gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
2916 gfc_expr *fp ATTRIBUTE_UNUSED,
2917 gfc_expr *l ATTRIBUTE_UNUSED,
2918 gfc_expr *to ATTRIBUTE_UNUSED,
2919 gfc_expr *tp ATTRIBUTE_UNUSED)
2920 {
2921 return NULL;
2922 }
2923
2924
2925 gfc_expr *
2926 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
2927 {
2928 gfc_expr *result;
2929 mp_exp_t emin, emax;
2930 int kind;
2931
2932 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2933 return NULL;
2934
2935 if (mpfr_sgn (s->value.real) == 0)
2936 {
2937 gfc_error ("Second argument of NEAREST at %L shall not be zero",
2938 &s->where);
2939 return &gfc_bad_expr;
2940 }
2941
2942 result = gfc_copy_expr (x);
2943
2944 /* Save current values of emin and emax. */
2945 emin = mpfr_get_emin ();
2946 emax = mpfr_get_emax ();
2947
2948 /* Set emin and emax for the current model number. */
2949 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
2950 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
2951 mpfr_get_prec(result->value.real) + 1);
2952 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
2953
2954 if (mpfr_sgn (s->value.real) > 0)
2955 {
2956 mpfr_nextabove (result->value.real);
2957 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
2958 }
2959 else
2960 {
2961 mpfr_nextbelow (result->value.real);
2962 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
2963 }
2964
2965 mpfr_set_emin (emin);
2966 mpfr_set_emax (emax);
2967
2968 /* Only NaN can occur. Do not use range check as it gives an
2969 error for denormal numbers. */
2970 if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
2971 {
2972 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
2973 gfc_free_expr (result);
2974 return &gfc_bad_expr;
2975 }
2976
2977 return result;
2978 }
2979
2980
2981 static gfc_expr *
2982 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
2983 {
2984 gfc_expr *itrunc, *result;
2985 int kind;
2986
2987 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
2988 if (kind == -1)
2989 return &gfc_bad_expr;
2990
2991 if (e->expr_type != EXPR_CONSTANT)
2992 return NULL;
2993
2994 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
2995
2996 itrunc = gfc_copy_expr (e);
2997
2998 mpfr_round (itrunc->value.real, e->value.real);
2999
3000 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
3001
3002 gfc_free_expr (itrunc);
3003
3004 return range_check (result, name);
3005 }
3006
3007
3008 gfc_expr *
3009 gfc_simplify_new_line (gfc_expr *e)
3010 {
3011 gfc_expr *result;
3012
3013 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3014 result->value.character.string = gfc_get_wide_string (2);
3015 result->value.character.length = 1;
3016 result->value.character.string[0] = '\n';
3017 result->value.character.string[1] = '\0'; /* For debugger */
3018 return result;
3019 }
3020
3021
3022 gfc_expr *
3023 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
3024 {
3025 return simplify_nint ("NINT", e, k);
3026 }
3027
3028
3029 gfc_expr *
3030 gfc_simplify_idnint (gfc_expr *e)
3031 {
3032 return simplify_nint ("IDNINT", e, NULL);
3033 }
3034
3035
3036 gfc_expr *
3037 gfc_simplify_not (gfc_expr *e)
3038 {
3039 gfc_expr *result;
3040
3041 if (e->expr_type != EXPR_CONSTANT)
3042 return NULL;
3043
3044 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3045
3046 mpz_com (result->value.integer, e->value.integer);
3047
3048 return range_check (result, "NOT");
3049 }
3050
3051
3052 gfc_expr *
3053 gfc_simplify_null (gfc_expr *mold)
3054 {
3055 gfc_expr *result;
3056
3057 if (mold == NULL)
3058 {
3059 result = gfc_get_expr ();
3060 result->ts.type = BT_UNKNOWN;
3061 }
3062 else
3063 result = gfc_copy_expr (mold);
3064 result->expr_type = EXPR_NULL;
3065
3066 return result;
3067 }
3068
3069
3070 gfc_expr *
3071 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
3072 {
3073 gfc_expr *result;
3074 int kind;
3075
3076 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3077 return NULL;
3078
3079 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3080 if (x->ts.type == BT_INTEGER)
3081 {
3082 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
3083 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3084 return range_check (result, "OR");
3085 }
3086 else /* BT_LOGICAL */
3087 {
3088 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
3089 result->value.logical = x->value.logical || y->value.logical;
3090 return result;
3091 }
3092 }
3093
3094
3095 gfc_expr *
3096 gfc_simplify_precision (gfc_expr *e)
3097 {
3098 gfc_expr *result;
3099 int i;
3100
3101 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3102
3103 result = gfc_int_expr (gfc_real_kinds[i].precision);
3104 result->where = e->where;
3105
3106 return result;
3107 }
3108
3109
3110 gfc_expr *
3111 gfc_simplify_radix (gfc_expr *e)
3112 {
3113 gfc_expr *result;
3114 int i;
3115
3116 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3117 switch (e->ts.type)
3118 {
3119 case BT_INTEGER:
3120 i = gfc_integer_kinds[i].radix;
3121 break;
3122
3123 case BT_REAL:
3124 i = gfc_real_kinds[i].radix;
3125 break;
3126
3127 default:
3128 gcc_unreachable ();
3129 }
3130
3131 result = gfc_int_expr (i);
3132 result->where = e->where;
3133
3134 return result;
3135 }
3136
3137
3138 gfc_expr *
3139 gfc_simplify_range (gfc_expr *e)
3140 {
3141 gfc_expr *result;
3142 int i;
3143 long j;
3144
3145 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3146
3147 switch (e->ts.type)
3148 {
3149 case BT_INTEGER:
3150 j = gfc_integer_kinds[i].range;
3151 break;
3152
3153 case BT_REAL:
3154 case BT_COMPLEX:
3155 j = gfc_real_kinds[i].range;
3156 break;
3157
3158 default:
3159 gcc_unreachable ();
3160 }
3161
3162 result = gfc_int_expr (j);
3163 result->where = e->where;
3164
3165 return result;
3166 }
3167
3168
3169 gfc_expr *
3170 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
3171 {
3172 gfc_expr *result = NULL;
3173 int kind;
3174
3175 if (e->ts.type == BT_COMPLEX)
3176 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
3177 else
3178 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
3179
3180 if (kind == -1)
3181 return &gfc_bad_expr;
3182
3183 if (e->expr_type != EXPR_CONSTANT)
3184 return NULL;
3185
3186 switch (e->ts.type)
3187 {
3188 case BT_INTEGER:
3189 if (!e->is_boz)
3190 result = gfc_int2real (e, kind);
3191 break;
3192
3193 case BT_REAL:
3194 result = gfc_real2real (e, kind);
3195 break;
3196
3197 case BT_COMPLEX:
3198 result = gfc_complex2real (e, kind);
3199 break;
3200
3201 default:
3202 gfc_internal_error ("bad type in REAL");
3203 /* Not reached */
3204 }
3205
3206 if (e->ts.type == BT_INTEGER && e->is_boz)
3207 {
3208 gfc_typespec ts;
3209 gfc_clear_ts (&ts);
3210 ts.type = BT_REAL;
3211 ts.kind = kind;
3212 result = gfc_copy_expr (e);
3213 if (!gfc_convert_boz (result, &ts))
3214 {
3215 gfc_free_expr (result);
3216 return &gfc_bad_expr;
3217 }
3218 }
3219
3220 return range_check (result, "REAL");
3221 }
3222
3223
3224 gfc_expr *
3225 gfc_simplify_realpart (gfc_expr *e)
3226 {
3227 gfc_expr *result;
3228
3229 if (e->expr_type != EXPR_CONSTANT)
3230 return NULL;
3231
3232 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3233 mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
3234
3235 return range_check (result, "REALPART");
3236 }
3237
3238 gfc_expr *
3239 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
3240 {
3241 gfc_expr *result;
3242 int i, j, len, ncop, nlen;
3243 mpz_t ncopies;
3244 bool have_length = false;
3245
3246 /* If NCOPIES isn't a constant, there's nothing we can do. */
3247 if (n->expr_type != EXPR_CONSTANT)
3248 return NULL;
3249
3250 /* If NCOPIES is negative, it's an error. */
3251 if (mpz_sgn (n->value.integer) < 0)
3252 {
3253 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
3254 &n->where);
3255 return &gfc_bad_expr;
3256 }
3257
3258 /* If we don't know the character length, we can do no more. */
3259 if (e->ts.cl && e->ts.cl->length
3260 && e->ts.cl->length->expr_type == EXPR_CONSTANT)
3261 {
3262 len = mpz_get_si (e->ts.cl->length->value.integer);
3263 have_length = true;
3264 }
3265 else if (e->expr_type == EXPR_CONSTANT
3266 && (e->ts.cl == NULL || e->ts.cl->length == NULL))
3267 {
3268 len = e->value.character.length;
3269 }
3270 else
3271 return NULL;
3272
3273 /* If the source length is 0, any value of NCOPIES is valid
3274 and everything behaves as if NCOPIES == 0. */
3275 mpz_init (ncopies);
3276 if (len == 0)
3277 mpz_set_ui (ncopies, 0);
3278 else
3279 mpz_set (ncopies, n->value.integer);
3280
3281 /* Check that NCOPIES isn't too large. */
3282 if (len)
3283 {
3284 mpz_t max, mlen;
3285 int i;
3286
3287 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
3288 mpz_init (max);
3289 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3290
3291 if (have_length)
3292 {
3293 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
3294 e->ts.cl->length->value.integer);
3295 }
3296 else
3297 {
3298 mpz_init_set_si (mlen, len);
3299 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
3300 mpz_clear (mlen);
3301 }
3302
3303 /* The check itself. */
3304 if (mpz_cmp (ncopies, max) > 0)
3305 {
3306 mpz_clear (max);
3307 mpz_clear (ncopies);
3308 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
3309 &n->where);
3310 return &gfc_bad_expr;
3311 }
3312
3313 mpz_clear (max);
3314 }
3315 mpz_clear (ncopies);
3316
3317 /* For further simplification, we need the character string to be
3318 constant. */
3319 if (e->expr_type != EXPR_CONSTANT)
3320 return NULL;
3321
3322 if (len ||
3323 (e->ts.cl->length &&
3324 mpz_sgn (e->ts.cl->length->value.integer)) != 0)
3325 {
3326 const char *res = gfc_extract_int (n, &ncop);
3327 gcc_assert (res == NULL);
3328 }
3329 else
3330 ncop = 0;
3331
3332 len = e->value.character.length;
3333 nlen = ncop * len;
3334
3335 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3336
3337 if (ncop == 0)
3338 {
3339 result->value.character.string = gfc_get_wide_string (1);
3340 result->value.character.length = 0;
3341 result->value.character.string[0] = '\0';
3342 return result;
3343 }
3344
3345 result->value.character.length = nlen;
3346 result->value.character.string = gfc_get_wide_string (nlen + 1);
3347
3348 for (i = 0; i < ncop; i++)
3349 for (j = 0; j < len; j++)
3350 result->value.character.string[j+i*len]= e->value.character.string[j];
3351
3352 result->value.character.string[nlen] = '\0'; /* For debugger */
3353 return result;
3354 }
3355
3356
3357 /* Test that the expression is an constant array. */
3358
3359 static bool
3360 is_constant_array_expr (gfc_expr *e)
3361 {
3362 gfc_constructor *c;
3363
3364 if (e == NULL)
3365 return true;
3366
3367 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
3368 return false;
3369
3370 if (e->value.constructor == NULL)
3371 return false;
3372
3373 for (c = e->value.constructor; c; c = c->next)
3374 if (c->expr->expr_type != EXPR_CONSTANT)
3375 return false;
3376
3377 return true;
3378 }
3379
3380
3381 /* This one is a bear, but mainly has to do with shuffling elements. */
3382
3383 gfc_expr *
3384 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
3385 gfc_expr *pad, gfc_expr *order_exp)
3386 {
3387 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
3388 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
3389 gfc_constructor *head, *tail;
3390 mpz_t index, size;
3391 unsigned long j;
3392 size_t nsource;
3393 gfc_expr *e;
3394
3395 /* Check that argument expression types are OK. */
3396 if (!is_constant_array_expr (source))
3397 return NULL;
3398
3399 if (!is_constant_array_expr (shape_exp))
3400 return NULL;
3401
3402 if (!is_constant_array_expr (pad))
3403 return NULL;
3404
3405 if (!is_constant_array_expr (order_exp))
3406 return NULL;
3407
3408 /* Proceed with simplification, unpacking the array. */
3409
3410 mpz_init (index);
3411 rank = 0;
3412 head = tail = NULL;
3413
3414 for (;;)
3415 {
3416 e = gfc_get_array_element (shape_exp, rank);
3417 if (e == NULL)
3418 break;
3419
3420 if (gfc_extract_int (e, &shape[rank]) != NULL)
3421 {
3422 gfc_error ("Integer too large in shape specification at %L",
3423 &e->where);
3424 gfc_free_expr (e);
3425 goto bad_reshape;
3426 }
3427
3428 if (rank >= GFC_MAX_DIMENSIONS)
3429 {
3430 gfc_error ("Too many dimensions in shape specification for RESHAPE "
3431 "at %L", &e->where);
3432 gfc_free_expr (e);
3433 goto bad_reshape;
3434 }
3435
3436 if (shape[rank] < 0)
3437 {
3438 gfc_error ("Shape specification at %L cannot be negative",
3439 &e->where);
3440 gfc_free_expr (e);
3441 goto bad_reshape;
3442 }
3443
3444 gfc_free_expr (e);
3445 rank++;
3446 }
3447
3448 if (rank == 0)
3449 {
3450 gfc_error ("Shape specification at %L cannot be the null array",
3451 &shape_exp->where);
3452 goto bad_reshape;
3453 }
3454
3455 /* Now unpack the order array if present. */
3456 if (order_exp == NULL)
3457 {
3458 for (i = 0; i < rank; i++)
3459 order[i] = i;
3460 }
3461 else
3462 {
3463 for (i = 0; i < rank; i++)
3464 x[i] = 0;
3465
3466 for (i = 0; i < rank; i++)
3467 {
3468 e = gfc_get_array_element (order_exp, i);
3469 if (e == NULL)
3470 {
3471 gfc_error ("ORDER parameter of RESHAPE at %L is not the same "
3472 "size as SHAPE parameter", &order_exp->where);
3473 goto bad_reshape;
3474 }
3475
3476 if (gfc_extract_int (e, &order[i]) != NULL)
3477 {
3478 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
3479 &e->where);
3480 gfc_free_expr (e);
3481 goto bad_reshape;
3482 }
3483
3484 if (order[i] < 1 || order[i] > rank)
3485 {
3486 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
3487 &e->where);
3488 gfc_free_expr (e);
3489 goto bad_reshape;
3490 }
3491
3492 order[i]--;
3493
3494 if (x[order[i]])
3495 {
3496 gfc_error ("Invalid permutation in ORDER parameter at %L",
3497 &e->where);
3498 gfc_free_expr (e);
3499 goto bad_reshape;
3500 }
3501
3502 gfc_free_expr (e);
3503
3504 x[order[i]] = 1;
3505 }
3506 }
3507
3508 /* Count the elements in the source and padding arrays. */
3509
3510 npad = 0;
3511 if (pad != NULL)
3512 {
3513 gfc_array_size (pad, &size);
3514 npad = mpz_get_ui (size);
3515 mpz_clear (size);
3516 }
3517
3518 gfc_array_size (source, &size);
3519 nsource = mpz_get_ui (size);
3520 mpz_clear (size);
3521
3522 /* If it weren't for that pesky permutation we could just loop
3523 through the source and round out any shortage with pad elements.
3524 But no, someone just had to have the compiler do something the
3525 user should be doing. */
3526
3527 for (i = 0; i < rank; i++)
3528 x[i] = 0;
3529
3530 for (;;)
3531 {
3532 /* Figure out which element to extract. */
3533 mpz_set_ui (index, 0);
3534
3535 for (i = rank - 1; i >= 0; i--)
3536 {
3537 mpz_add_ui (index, index, x[order[i]]);
3538 if (i != 0)
3539 mpz_mul_ui (index, index, shape[order[i - 1]]);
3540 }
3541
3542 if (mpz_cmp_ui (index, INT_MAX) > 0)
3543 gfc_internal_error ("Reshaped array too large at %C");
3544
3545 j = mpz_get_ui (index);
3546
3547 if (j < nsource)
3548 e = gfc_get_array_element (source, j);
3549 else
3550 {
3551 j = j - nsource;
3552
3553 if (npad == 0)
3554 {
3555 gfc_error ("PAD parameter required for short SOURCE parameter "
3556 "at %L", &source->where);
3557 goto bad_reshape;
3558 }
3559
3560 j = j % npad;
3561 e = gfc_get_array_element (pad, j);
3562 }
3563
3564 if (head == NULL)
3565 head = tail = gfc_get_constructor ();
3566 else
3567 {
3568 tail->next = gfc_get_constructor ();
3569 tail = tail->next;
3570 }
3571
3572 if (e == NULL)
3573 goto bad_reshape;
3574
3575 tail->where = e->where;
3576 tail->expr = e;
3577
3578 /* Calculate the next element. */
3579 i = 0;
3580
3581 inc:
3582 if (++x[i] < shape[i])
3583 continue;
3584 x[i++] = 0;
3585 if (i < rank)
3586 goto inc;
3587
3588 break;
3589 }
3590
3591 mpz_clear (index);
3592
3593 e = gfc_get_expr ();
3594 e->where = source->where;
3595 e->expr_type = EXPR_ARRAY;
3596 e->value.constructor = head;
3597 e->shape = gfc_get_shape (rank);
3598
3599 for (i = 0; i < rank; i++)
3600 mpz_init_set_ui (e->shape[i], shape[i]);
3601
3602 e->ts = source->ts;
3603 e->rank = rank;
3604
3605 return e;
3606
3607 bad_reshape:
3608 gfc_free_constructor (head);
3609 mpz_clear (index);
3610 return &gfc_bad_expr;
3611 }
3612
3613
3614 gfc_expr *
3615 gfc_simplify_rrspacing (gfc_expr *x)
3616 {
3617 gfc_expr *result;
3618 int i;
3619 long int e, p;
3620
3621 if (x->expr_type != EXPR_CONSTANT)
3622 return NULL;
3623
3624 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3625
3626 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3627
3628 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3629
3630 /* Special case x = -0 and 0. */
3631 if (mpfr_sgn (result->value.real) == 0)
3632 {
3633 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3634 return result;
3635 }
3636
3637 /* | x * 2**(-e) | * 2**p. */
3638 e = - (long int) mpfr_get_exp (x->value.real);
3639 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
3640
3641 p = (long int) gfc_real_kinds[i].digits;
3642 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
3643
3644 return range_check (result, "RRSPACING");
3645 }
3646
3647
3648 gfc_expr *
3649 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
3650 {
3651 int k, neg_flag, power, exp_range;
3652 mpfr_t scale, radix;
3653 gfc_expr *result;
3654
3655 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3656 return NULL;
3657
3658 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3659
3660 if (mpfr_sgn (x->value.real) == 0)
3661 {
3662 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3663 return result;
3664 }
3665
3666 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3667
3668 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3669
3670 /* This check filters out values of i that would overflow an int. */
3671 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3672 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3673 {
3674 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3675 gfc_free_expr (result);
3676 return &gfc_bad_expr;
3677 }
3678
3679 /* Compute scale = radix ** power. */
3680 power = mpz_get_si (i->value.integer);
3681
3682 if (power >= 0)
3683 neg_flag = 0;
3684 else
3685 {
3686 neg_flag = 1;
3687 power = -power;
3688 }
3689
3690 gfc_set_model_kind (x->ts.kind);
3691 mpfr_init (scale);
3692 mpfr_init (radix);
3693 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3694 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3695
3696 if (neg_flag)
3697 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3698 else
3699 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3700
3701 mpfr_clears (scale, radix, NULL);
3702
3703 return range_check (result, "SCALE");
3704 }
3705
3706
3707 /* Variants of strspn and strcspn that operate on wide characters. */
3708
3709 static size_t
3710 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
3711 {
3712 size_t i = 0;
3713 const gfc_char_t *c;
3714
3715 while (s1[i])
3716 {
3717 for (c = s2; *c; c++)
3718 {
3719 if (s1[i] == *c)
3720 break;
3721 }
3722 if (*c == '\0')
3723 break;
3724 i++;
3725 }
3726
3727 return i;
3728 }
3729
3730 static size_t
3731 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
3732 {
3733 size_t i = 0;
3734 const gfc_char_t *c;
3735
3736 while (s1[i])
3737 {
3738 for (c = s2; *c; c++)
3739 {
3740 if (s1[i] == *c)
3741 break;
3742 }
3743 if (*c)
3744 break;
3745 i++;
3746 }
3747
3748 return i;
3749 }
3750
3751
3752 gfc_expr *
3753 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
3754 {
3755 gfc_expr *result;
3756 int back;
3757 size_t i;
3758 size_t indx, len, lenc;
3759 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
3760
3761 if (k == -1)
3762 return &gfc_bad_expr;
3763
3764 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3765 return NULL;
3766
3767 if (b != NULL && b->value.logical != 0)
3768 back = 1;
3769 else
3770 back = 0;
3771
3772 result = gfc_constant_result (BT_INTEGER, k, &e->where);
3773
3774 len = e->value.character.length;
3775 lenc = c->value.character.length;
3776
3777 if (len == 0 || lenc == 0)
3778 {
3779 indx = 0;
3780 }
3781 else
3782 {
3783 if (back == 0)
3784 {
3785 indx = wide_strcspn (e->value.character.string,
3786 c->value.character.string) + 1;
3787 if (indx > len)
3788 indx = 0;
3789 }
3790 else
3791 {
3792 i = 0;
3793 for (indx = len; indx > 0; indx--)
3794 {
3795 for (i = 0; i < lenc; i++)
3796 {
3797 if (c->value.character.string[i]
3798 == e->value.character.string[indx - 1])
3799 break;
3800 }
3801 if (i < lenc)
3802 break;
3803 }
3804 }
3805 }
3806 mpz_set_ui (result->value.integer, indx);
3807 return range_check (result, "SCAN");
3808 }
3809
3810
3811 gfc_expr *
3812 gfc_simplify_selected_char_kind (gfc_expr *e)
3813 {
3814 int kind;
3815 gfc_expr *result;
3816
3817 if (e->expr_type != EXPR_CONSTANT)
3818 return NULL;
3819
3820 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
3821 || gfc_compare_with_Cstring (e, "default", false) == 0)
3822 kind = 1;
3823 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
3824 kind = 4;
3825 else
3826 kind = -1;
3827
3828 result = gfc_int_expr (kind);
3829 result->where = e->where;
3830
3831 return result;
3832 }
3833
3834
3835 gfc_expr *
3836 gfc_simplify_selected_int_kind (gfc_expr *e)
3837 {
3838 int i, kind, range;
3839 gfc_expr *result;
3840
3841 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3842 return NULL;
3843
3844 kind = INT_MAX;
3845
3846 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3847 if (gfc_integer_kinds[i].range >= range
3848 && gfc_integer_kinds[i].kind < kind)
3849 kind = gfc_integer_kinds[i].kind;
3850
3851 if (kind == INT_MAX)
3852 kind = -1;
3853
3854 result = gfc_int_expr (kind);
3855 result->where = e->where;
3856
3857 return result;
3858 }
3859
3860
3861 gfc_expr *
3862 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
3863 {
3864 int range, precision, i, kind, found_precision, found_range;
3865 gfc_expr *result;
3866
3867 if (p == NULL)
3868 precision = 0;
3869 else
3870 {
3871 if (p->expr_type != EXPR_CONSTANT
3872 || gfc_extract_int (p, &precision) != NULL)
3873 return NULL;
3874 }
3875
3876 if (q == NULL)
3877 range = 0;
3878 else
3879 {
3880 if (q->expr_type != EXPR_CONSTANT
3881 || gfc_extract_int (q, &range) != NULL)
3882 return NULL;
3883 }
3884
3885 kind = INT_MAX;
3886 found_precision = 0;
3887 found_range = 0;
3888
3889 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3890 {
3891 if (gfc_real_kinds[i].precision >= precision)
3892 found_precision = 1;
3893
3894 if (gfc_real_kinds[i].range >= range)
3895 found_range = 1;
3896
3897 if (gfc_real_kinds[i].precision >= precision
3898 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3899 kind = gfc_real_kinds[i].kind;
3900 }
3901
3902 if (kind == INT_MAX)
3903 {
3904 kind = 0;
3905
3906 if (!found_precision)
3907 kind = -1;
3908 if (!found_range)
3909 kind -= 2;
3910 }
3911
3912 result = gfc_int_expr (kind);
3913 result->where = (p != NULL) ? p->where : q->where;
3914
3915 return result;
3916 }
3917
3918
3919 gfc_expr *
3920 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
3921 {
3922 gfc_expr *result;
3923 mpfr_t exp, absv, log2, pow2, frac;
3924 unsigned long exp2;
3925
3926 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3927 return NULL;
3928
3929 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3930
3931 if (mpfr_sgn (x->value.real) == 0)
3932 {
3933 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3934 return result;
3935 }
3936
3937 gfc_set_model_kind (x->ts.kind);
3938 mpfr_init (absv);
3939 mpfr_init (log2);
3940 mpfr_init (exp);
3941 mpfr_init (pow2);
3942 mpfr_init (frac);
3943
3944 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3945 mpfr_log2 (log2, absv, GFC_RND_MODE);
3946
3947 mpfr_trunc (log2, log2);
3948 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3949
3950 /* Old exponent value, and fraction. */
3951 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3952
3953 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3954
3955 /* New exponent. */
3956 exp2 = (unsigned long) mpz_get_d (i->value.integer);
3957 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3958
3959 mpfr_clears (absv, log2, pow2, frac, NULL);
3960
3961 return range_check (result, "SET_EXPONENT");
3962 }
3963
3964
3965 gfc_expr *
3966 gfc_simplify_shape (gfc_expr *source)
3967 {
3968 mpz_t shape[GFC_MAX_DIMENSIONS];
3969 gfc_expr *result, *e, *f;
3970 gfc_array_ref *ar;
3971 int n;
3972 gfc_try t;
3973
3974 if (source->rank == 0)
3975 return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3976 &source->where);
3977
3978 if (source->expr_type != EXPR_VARIABLE)
3979 return NULL;
3980
3981 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3982 &source->where);
3983
3984 ar = gfc_find_array_ref (source);
3985
3986 t = gfc_array_ref_shape (ar, shape);
3987
3988 for (n = 0; n < source->rank; n++)
3989 {
3990 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3991 &source->where);
3992
3993 if (t == SUCCESS)
3994 {
3995 mpz_set (e->value.integer, shape[n]);
3996 mpz_clear (shape[n]);
3997 }
3998 else
3999 {
4000 mpz_set_ui (e->value.integer, n + 1);
4001
4002 f = gfc_simplify_size (source, e, NULL);
4003 gfc_free_expr (e);
4004 if (f == NULL)
4005 {
4006 gfc_free_expr (result);
4007 return NULL;
4008 }
4009 else
4010 {
4011 e = f;
4012 }
4013 }
4014
4015 gfc_append_constructor (result, e);
4016 }
4017
4018 return result;
4019 }
4020
4021
4022 gfc_expr *
4023 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4024 {
4025 mpz_t size;
4026 gfc_expr *result;
4027 int d;
4028 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
4029
4030 if (k == -1)
4031 return &gfc_bad_expr;
4032
4033 if (dim == NULL)
4034 {
4035 if (gfc_array_size (array, &size) == FAILURE)
4036 return NULL;
4037 }
4038 else
4039 {
4040 if (dim->expr_type != EXPR_CONSTANT)
4041 return NULL;
4042
4043 d = mpz_get_ui (dim->value.integer) - 1;
4044 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
4045 return NULL;
4046 }
4047
4048 result = gfc_constant_result (BT_INTEGER, k, &array->where);
4049 mpz_set (result->value.integer, size);
4050 return result;
4051 }
4052
4053
4054 gfc_expr *
4055 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
4056 {
4057 gfc_expr *result;
4058
4059 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4060 return NULL;
4061
4062 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4063
4064 switch (x->ts.type)
4065 {
4066 case BT_INTEGER:
4067 mpz_abs (result->value.integer, x->value.integer);
4068 if (mpz_sgn (y->value.integer) < 0)
4069 mpz_neg (result->value.integer, result->value.integer);
4070
4071 break;
4072
4073 case BT_REAL:
4074 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
4075 it. */
4076 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4077 if (mpfr_sgn (y->value.real) < 0)
4078 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
4079
4080 break;
4081
4082 default:
4083 gfc_internal_error ("Bad type in gfc_simplify_sign");
4084 }
4085
4086 return result;
4087 }
4088
4089
4090 gfc_expr *
4091 gfc_simplify_sin (gfc_expr *x)
4092 {
4093 gfc_expr *result;
4094 mpfr_t xp, xq;
4095
4096 if (x->expr_type != EXPR_CONSTANT)
4097 return NULL;
4098
4099 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4100
4101 switch (x->ts.type)
4102 {
4103 case BT_REAL:
4104 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
4105 break;
4106
4107 case BT_COMPLEX:
4108 gfc_set_model (x->value.real);
4109 mpfr_init (xp);
4110 mpfr_init (xq);
4111
4112 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
4113 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
4114 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
4115
4116 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
4117 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
4118 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
4119
4120 mpfr_clears (xp, xq, NULL);
4121 break;
4122
4123 default:
4124 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
4125 }
4126
4127 return range_check (result, "SIN");
4128 }
4129
4130
4131 gfc_expr *
4132 gfc_simplify_sinh (gfc_expr *x)
4133 {
4134 gfc_expr *result;
4135
4136 if (x->expr_type != EXPR_CONSTANT)
4137 return NULL;
4138
4139 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4140
4141 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
4142
4143 return range_check (result, "SINH");
4144 }
4145
4146
4147 /* The argument is always a double precision real that is converted to
4148 single precision. TODO: Rounding! */
4149
4150 gfc_expr *
4151 gfc_simplify_sngl (gfc_expr *a)
4152 {
4153 gfc_expr *result;
4154
4155 if (a->expr_type != EXPR_CONSTANT)
4156 return NULL;
4157
4158 result = gfc_real2real (a, gfc_default_real_kind);
4159 return range_check (result, "SNGL");
4160 }
4161
4162
4163 gfc_expr *
4164 gfc_simplify_spacing (gfc_expr *x)
4165 {
4166 gfc_expr *result;
4167 int i;
4168 long int en, ep;
4169
4170 if (x->expr_type != EXPR_CONSTANT)
4171 return NULL;
4172
4173 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
4174
4175 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
4176
4177 /* Special case x = 0 and -0. */
4178 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
4179 if (mpfr_sgn (result->value.real) == 0)
4180 {
4181 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4182 return result;
4183 }
4184
4185 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
4186 are the radix, exponent of x, and precision. This excludes the
4187 possibility of subnormal numbers. Fortran 2003 states the result is
4188 b**max(e - p, emin - 1). */
4189
4190 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
4191 en = (long int) gfc_real_kinds[i].min_exponent - 1;
4192 en = en > ep ? en : ep;
4193
4194 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
4195 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
4196
4197 return range_check (result, "SPACING");
4198 }
4199
4200
4201 gfc_expr *
4202 gfc_simplify_sqrt (gfc_expr *e)
4203 {
4204 gfc_expr *result;
4205 mpfr_t ac, ad, s, t, w;
4206
4207 if (e->expr_type != EXPR_CONSTANT)
4208 return NULL;
4209
4210 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
4211
4212 switch (e->ts.type)
4213 {
4214 case BT_REAL:
4215 if (mpfr_cmp_si (e->value.real, 0) < 0)
4216 goto negative_arg;
4217 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
4218
4219 break;
4220
4221 case BT_COMPLEX:
4222 /* Formula taken from Numerical Recipes to avoid over- and
4223 underflow. */
4224
4225 gfc_set_model (e->value.real);
4226 mpfr_init (ac);
4227 mpfr_init (ad);
4228 mpfr_init (s);
4229 mpfr_init (t);
4230 mpfr_init (w);
4231
4232 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
4233 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
4234 {
4235 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
4236 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
4237 break;
4238 }
4239
4240 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
4241 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
4242
4243 if (mpfr_cmp (ac, ad) >= 0)
4244 {
4245 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
4246 mpfr_mul (t, t, t, GFC_RND_MODE);
4247 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4248 mpfr_sqrt (t, t, GFC_RND_MODE);
4249 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4250 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4251 mpfr_sqrt (t, t, GFC_RND_MODE);
4252 mpfr_sqrt (s, ac, GFC_RND_MODE);
4253 mpfr_mul (w, s, t, GFC_RND_MODE);
4254 }
4255 else
4256 {
4257 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
4258 mpfr_mul (t, s, s, GFC_RND_MODE);
4259 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
4260 mpfr_sqrt (t, t, GFC_RND_MODE);
4261 mpfr_abs (s, s, GFC_RND_MODE);
4262 mpfr_add (t, t, s, GFC_RND_MODE);
4263 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
4264 mpfr_sqrt (t, t, GFC_RND_MODE);
4265 mpfr_sqrt (s, ad, GFC_RND_MODE);
4266 mpfr_mul (w, s, t, GFC_RND_MODE);
4267 }
4268
4269 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
4270 {
4271 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4272 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
4273 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
4274 }
4275 else if (mpfr_cmp_ui (w, 0) != 0
4276 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4277 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
4278 {
4279 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4280 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
4281 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4282 }
4283 else if (mpfr_cmp_ui (w, 0) != 0
4284 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
4285 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
4286 {
4287 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
4288 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
4289 mpfr_neg (w, w, GFC_RND_MODE);
4290 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
4291 }
4292 else
4293 gfc_internal_error ("invalid complex argument of SQRT at %L",
4294 &e->where);
4295
4296 mpfr_clears (s, t, ac, ad, w, NULL);
4297
4298 break;
4299
4300 default:
4301 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
4302 }
4303
4304 return range_check (result, "SQRT");
4305
4306 negative_arg:
4307 gfc_free_expr (result);
4308 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
4309 return &gfc_bad_expr;
4310 }
4311
4312
4313 gfc_expr *
4314 gfc_simplify_tan (gfc_expr *x)
4315 {
4316 int i;
4317 gfc_expr *result;
4318
4319 if (x->expr_type != EXPR_CONSTANT)
4320 return NULL;
4321
4322 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4323
4324 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4325
4326 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
4327
4328 return range_check (result, "TAN");
4329 }
4330
4331
4332 gfc_expr *
4333 gfc_simplify_tanh (gfc_expr *x)
4334 {
4335 gfc_expr *result;
4336
4337 if (x->expr_type != EXPR_CONSTANT)
4338 return NULL;
4339
4340 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
4341
4342 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
4343
4344 return range_check (result, "TANH");
4345
4346 }
4347
4348
4349 gfc_expr *
4350 gfc_simplify_tiny (gfc_expr *e)
4351 {
4352 gfc_expr *result;
4353 int i;
4354
4355 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
4356
4357 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
4358 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
4359
4360 return result;
4361 }
4362
4363
4364 gfc_expr *
4365 gfc_simplify_trailz (gfc_expr *e)
4366 {
4367 gfc_expr *result;
4368 unsigned long tz, bs;
4369 int i;
4370
4371 if (e->expr_type != EXPR_CONSTANT)
4372 return NULL;
4373
4374 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4375 bs = gfc_integer_kinds[i].bit_size;
4376 tz = mpz_scan1 (e->value.integer, 0);
4377
4378 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
4379 mpz_set_ui (result->value.integer, MIN (tz, bs));
4380
4381 return result;
4382 }
4383
4384
4385 gfc_expr *
4386 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
4387 {
4388 gfc_expr *result;
4389 gfc_expr *mold_element;
4390 size_t source_size;
4391 size_t result_size;
4392 size_t result_elt_size;
4393 size_t buffer_size;
4394 mpz_t tmp;
4395 unsigned char *buffer;
4396
4397 if (!gfc_is_constant_expr (source)
4398 || (gfc_init_expr && !gfc_is_constant_expr (mold))
4399 || !gfc_is_constant_expr (size))
4400 return NULL;
4401
4402 if (source->expr_type == EXPR_FUNCTION)
4403 return NULL;
4404
4405 /* Calculate the size of the source. */
4406 if (source->expr_type == EXPR_ARRAY
4407 && gfc_array_size (source, &tmp) == FAILURE)
4408 gfc_internal_error ("Failure getting length of a constant array.");
4409
4410 source_size = gfc_target_expr_size (source);
4411
4412 /* Create an empty new expression with the appropriate characteristics. */
4413 result = gfc_constant_result (mold->ts.type, mold->ts.kind,
4414 &source->where);
4415 result->ts = mold->ts;
4416
4417 mold_element = mold->expr_type == EXPR_ARRAY
4418 ? mold->value.constructor->expr
4419 : mold;
4420
4421 /* Set result character length, if needed. Note that this needs to be
4422 set even for array expressions, in order to pass this information into
4423 gfc_target_interpret_expr. */
4424 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
4425 result->value.character.length = mold_element->value.character.length;
4426
4427 /* Set the number of elements in the result, and determine its size. */
4428 result_elt_size = gfc_target_expr_size (mold_element);
4429 if (result_elt_size == 0)
4430 {
4431 gfc_free_expr (result);
4432 return NULL;
4433 }
4434
4435 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
4436 {
4437 int result_length;
4438
4439 result->expr_type = EXPR_ARRAY;
4440 result->rank = 1;
4441
4442 if (size)
4443 result_length = (size_t)mpz_get_ui (size->value.integer);
4444 else
4445 {
4446 result_length = source_size / result_elt_size;
4447 if (result_length * result_elt_size < source_size)
4448 result_length += 1;
4449 }
4450
4451 result->shape = gfc_get_shape (1);
4452 mpz_init_set_ui (result->shape[0], result_length);
4453
4454 result_size = result_length * result_elt_size;
4455 }
4456 else
4457 {
4458 result->rank = 0;
4459 result_size = result_elt_size;
4460 }
4461
4462 if (gfc_option.warn_surprising && source_size < result_size)
4463 gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
4464 "source size %ld < result size %ld", &source->where,
4465 (long) source_size, (long) result_size);
4466
4467 /* Allocate the buffer to store the binary version of the source. */
4468 buffer_size = MAX (source_size, result_size);
4469 buffer = (unsigned char*)alloca (buffer_size);
4470
4471 /* Now write source to the buffer. */
4472 gfc_target_encode_expr (source, buffer, buffer_size);
4473
4474 /* And read the buffer back into the new expression. */
4475 gfc_target_interpret_expr (buffer, buffer_size, result);
4476
4477 return result;
4478 }
4479
4480
4481 gfc_expr *
4482 gfc_simplify_trim (gfc_expr *e)
4483 {
4484 gfc_expr *result;
4485 int count, i, len, lentrim;
4486
4487 if (e->expr_type != EXPR_CONSTANT)
4488 return NULL;
4489
4490 len = e->value.character.length;
4491
4492 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
4493
4494 for (count = 0, i = 1; i <= len; ++i)
4495 {
4496 if (e->value.character.string[len - i] == ' ')
4497 count++;
4498 else
4499 break;
4500 }
4501
4502 lentrim = len - count;
4503
4504 result->value.character.length = lentrim;
4505 result->value.character.string = gfc_get_wide_string (lentrim + 1);
4506
4507 for (i = 0; i < lentrim; i++)
4508 result->value.character.string[i] = e->value.character.string[i];
4509
4510 result->value.character.string[lentrim] = '\0'; /* For debugger */
4511
4512 return result;
4513 }
4514
4515
4516 gfc_expr *
4517 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4518 {
4519 return simplify_bound (array, dim, kind, 1);
4520 }
4521
4522
4523 gfc_expr *
4524 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
4525 {
4526 gfc_expr *result;
4527 int back;
4528 size_t index, len, lenset;
4529 size_t i;
4530 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
4531
4532 if (k == -1)
4533 return &gfc_bad_expr;
4534
4535 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
4536 return NULL;
4537
4538 if (b != NULL && b->value.logical != 0)
4539 back = 1;
4540 else
4541 back = 0;
4542
4543 result = gfc_constant_result (BT_INTEGER, k, &s->where);
4544
4545 len = s->value.character.length;
4546 lenset = set->value.character.length;
4547
4548 if (len == 0)
4549 {
4550 mpz_set_ui (result->value.integer, 0);
4551 return result;
4552 }
4553
4554 if (back == 0)
4555 {
4556 if (lenset == 0)
4557 {
4558 mpz_set_ui (result->value.integer, 1);
4559 return result;
4560 }
4561
4562 index = wide_strspn (s->value.character.string,
4563 set->value.character.string) + 1;
4564 if (index > len)
4565 index = 0;
4566
4567 }
4568 else
4569 {
4570 if (lenset == 0)
4571 {
4572 mpz_set_ui (result->value.integer, len);
4573 return result;
4574 }
4575 for (index = len; index > 0; index --)
4576 {
4577 for (i = 0; i < lenset; i++)
4578 {
4579 if (s->value.character.string[index - 1]
4580 == set->value.character.string[i])
4581 break;
4582 }
4583 if (i == lenset)
4584 break;
4585 }
4586 }
4587
4588 mpz_set_ui (result->value.integer, index);
4589 return result;
4590 }
4591
4592
4593 gfc_expr *
4594 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
4595 {
4596 gfc_expr *result;
4597 int kind;
4598
4599 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4600 return NULL;
4601
4602 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4603 if (x->ts.type == BT_INTEGER)
4604 {
4605 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
4606 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
4607 return range_check (result, "XOR");
4608 }
4609 else /* BT_LOGICAL */
4610 {
4611 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
4612 result->value.logical = (x->value.logical && !y->value.logical)
4613 || (!x->value.logical && y->value.logical);
4614 return result;
4615 }
4616
4617 }
4618
4619
4620 /****************** Constant simplification *****************/
4621
4622 /* Master function to convert one constant to another. While this is
4623 used as a simplification function, it requires the destination type
4624 and kind information which is supplied by a special case in
4625 do_simplify(). */
4626
4627 gfc_expr *
4628 gfc_convert_constant (gfc_expr *e, bt type, int kind)
4629 {
4630 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
4631 gfc_constructor *head, *c, *tail = NULL;
4632
4633 switch (e->ts.type)
4634 {
4635 case BT_INTEGER:
4636 switch (type)
4637 {
4638 case BT_INTEGER:
4639 f = gfc_int2int;
4640 break;
4641 case BT_REAL:
4642 f = gfc_int2real;
4643 break;
4644 case BT_COMPLEX:
4645 f = gfc_int2complex;
4646 break;
4647 case BT_LOGICAL:
4648 f = gfc_int2log;
4649 break;
4650 default:
4651 goto oops;
4652 }
4653 break;
4654
4655 case BT_REAL:
4656 switch (type)
4657 {
4658 case BT_INTEGER:
4659 f = gfc_real2int;
4660 break;
4661 case BT_REAL:
4662 f = gfc_real2real;
4663 break;
4664 case BT_COMPLEX:
4665 f = gfc_real2complex;
4666 break;
4667 default:
4668 goto oops;
4669 }
4670 break;
4671
4672 case BT_COMPLEX:
4673 switch (type)
4674 {
4675 case BT_INTEGER:
4676 f = gfc_complex2int;
4677 break;
4678 case BT_REAL:
4679 f = gfc_complex2real;
4680 break;
4681 case BT_COMPLEX:
4682 f = gfc_complex2complex;
4683 break;
4684
4685 default:
4686 goto oops;
4687 }
4688 break;
4689
4690 case BT_LOGICAL:
4691 switch (type)
4692 {
4693 case BT_INTEGER:
4694 f = gfc_log2int;
4695 break;
4696 case BT_LOGICAL:
4697 f = gfc_log2log;
4698 break;
4699 default:
4700 goto oops;
4701 }
4702 break;
4703
4704 case BT_HOLLERITH:
4705 switch (type)
4706 {
4707 case BT_INTEGER:
4708 f = gfc_hollerith2int;
4709 break;
4710
4711 case BT_REAL:
4712 f = gfc_hollerith2real;
4713 break;
4714
4715 case BT_COMPLEX:
4716 f = gfc_hollerith2complex;
4717 break;
4718
4719 case BT_CHARACTER:
4720 f = gfc_hollerith2character;
4721 break;
4722
4723 case BT_LOGICAL:
4724 f = gfc_hollerith2logical;
4725 break;
4726
4727 default:
4728 goto oops;
4729 }
4730 break;
4731
4732 default:
4733 oops:
4734 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
4735 }
4736
4737 result = NULL;
4738
4739 switch (e->expr_type)
4740 {
4741 case EXPR_CONSTANT:
4742 result = f (e, kind);
4743 if (result == NULL)
4744 return &gfc_bad_expr;
4745 break;
4746
4747 case EXPR_ARRAY:
4748 if (!gfc_is_constant_expr (e))
4749 break;
4750
4751 head = NULL;
4752
4753 for (c = e->value.constructor; c; c = c->next)
4754 {
4755 if (head == NULL)
4756 head = tail = gfc_get_constructor ();
4757 else
4758 {
4759 tail->next = gfc_get_constructor ();
4760 tail = tail->next;
4761 }
4762
4763 tail->where = c->where;
4764
4765 if (c->iterator == NULL)
4766 tail->expr = f (c->expr, kind);
4767 else
4768 {
4769 g = gfc_convert_constant (c->expr, type, kind);
4770 if (g == &gfc_bad_expr)
4771 return g;
4772 tail->expr = g;
4773 }
4774
4775 if (tail->expr == NULL)
4776 {
4777 gfc_free_constructor (head);
4778 return NULL;
4779 }
4780 }
4781
4782 result = gfc_get_expr ();
4783 result->ts.type = type;
4784 result->ts.kind = kind;
4785 result->expr_type = EXPR_ARRAY;
4786 result->value.constructor = head;
4787 result->shape = gfc_copy_shape (e->shape, e->rank);
4788 result->where = e->where;
4789 result->rank = e->rank;
4790 break;
4791
4792 default:
4793 break;
4794 }
4795
4796 return result;
4797 }
4798
4799
4800 /* Function for converting character constants. */
4801 gfc_expr *
4802 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
4803 {
4804 gfc_expr *result;
4805 int i;
4806
4807 if (!gfc_is_constant_expr (e))
4808 return NULL;
4809
4810 if (e->expr_type == EXPR_CONSTANT)
4811 {
4812 /* Simple case of a scalar. */
4813 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
4814 if (result == NULL)
4815 return &gfc_bad_expr;
4816
4817 result->value.character.length = e->value.character.length;
4818 result->value.character.string
4819 = gfc_get_wide_string (e->value.character.length + 1);
4820 memcpy (result->value.character.string, e->value.character.string,
4821 (e->value.character.length + 1) * sizeof (gfc_char_t));
4822
4823 /* Check we only have values representable in the destination kind. */
4824 for (i = 0; i < result->value.character.length; i++)
4825 if (!gfc_check_character_range (result->value.character.string[i],
4826 kind))
4827 {
4828 gfc_error ("Character '%s' in string at %L cannot be converted "
4829 "into character kind %d",
4830 gfc_print_wide_char (result->value.character.string[i]),
4831 &e->where, kind);
4832 return &gfc_bad_expr;
4833 }
4834
4835 return result;
4836 }
4837 else if (e->expr_type == EXPR_ARRAY)
4838 {
4839 /* For an array constructor, we convert each constructor element. */
4840 gfc_constructor *head = NULL, *tail = NULL, *c;
4841
4842 for (c = e->value.constructor; c; c = c->next)
4843 {
4844 if (head == NULL)
4845 head = tail = gfc_get_constructor ();
4846 else
4847 {
4848 tail->next = gfc_get_constructor ();
4849 tail = tail->next;
4850 }
4851
4852 tail->where = c->where;
4853 tail->expr = gfc_convert_char_constant (c->expr, type, kind);
4854 if (tail->expr == &gfc_bad_expr)
4855 {
4856 tail->expr = NULL;
4857 return &gfc_bad_expr;
4858 }
4859
4860 if (tail->expr == NULL)
4861 {
4862 gfc_free_constructor (head);
4863 return NULL;
4864 }
4865 }
4866
4867 result = gfc_get_expr ();
4868 result->ts.type = type;
4869 result->ts.kind = kind;
4870 result->expr_type = EXPR_ARRAY;
4871 result->value.constructor = head;
4872 result->shape = gfc_copy_shape (e->shape, e->rank);
4873 result->where = e->where;
4874 result->rank = e->rank;
4875 result->ts.cl = e->ts.cl;
4876
4877 return result;
4878 }
4879 else
4880 return NULL;
4881 }