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