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