?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Check in tree-dce enh to trunk
[official-gcc.git] / gcc / fortran / simplify.c
blob4159374f06e64ffec6b68f1c9861378d2dcbd1e1
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 /* We use the processor's collating sequence, because all
260 systems that gfortran currently works on are ASCII. */
261
262 gfc_expr *
263 gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
264 {
265 gfc_expr *result;
266 int c, kind;
267 const char *ch;
268
269 if (e->expr_type != EXPR_CONSTANT)
270 return NULL;
271
272 kind = get_kind (BT_CHARACTER, k, "ACHAR", gfc_default_character_kind);
273 if (kind == -1)
274 return &gfc_bad_expr;
275
276 ch = gfc_extract_int (e, &c);
277
278 if (ch != NULL)
279 gfc_internal_error ("gfc_simplify_achar: %s", ch);
280
281 if (gfc_option.warn_surprising && (c < 0 || c > 127))
282 gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
283 &e->where);
284
285 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
286
287 result->value.character.string = gfc_get_wide_string (2);
288
289 result->value.character.length = 1;
290 result->value.character.string[0] = c;
291 result->value.character.string[1] = '\0'; /* For debugger */
292 return result;
293 }
294
295
296 gfc_expr *
297 gfc_simplify_acos (gfc_expr *x)
298 {
299 gfc_expr *result;
300
301 if (x->expr_type != EXPR_CONSTANT)
302 return NULL;
303
304 if (mpfr_cmp_si (x->value.real, 1) > 0
305 || mpfr_cmp_si (x->value.real, -1) < 0)
306 {
307 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
308 &x->where);
309 return &gfc_bad_expr;
310 }
311
312 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
313
314 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
315
316 return range_check (result, "ACOS");
317 }
318
319 gfc_expr *
320 gfc_simplify_acosh (gfc_expr *x)
321 {
322 gfc_expr *result;
323
324 if (x->expr_type != EXPR_CONSTANT)
325 return NULL;
326
327 if (mpfr_cmp_si (x->value.real, 1) < 0)
328 {
329 gfc_error ("Argument of ACOSH at %L must not be less than 1",
330 &x->where);
331 return &gfc_bad_expr;
332 }
333
334 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
335
336 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
337
338 return range_check (result, "ACOSH");
339 }
340
341 gfc_expr *
342 gfc_simplify_adjustl (gfc_expr *e)
343 {
344 gfc_expr *result;
345 int count, i, len;
346 gfc_char_t ch;
347
348 if (e->expr_type != EXPR_CONSTANT)
349 return NULL;
350
351 len = e->value.character.length;
352
353 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
354
355 result->value.character.length = len;
356 result->value.character.string = gfc_get_wide_string (len + 1);
357
358 for (count = 0, i = 0; i < len; ++i)
359 {
360 ch = e->value.character.string[i];
361 if (ch != ' ')
362 break;
363 ++count;
364 }
365
366 for (i = 0; i < len - count; ++i)
367 result->value.character.string[i] = e->value.character.string[count + i];
368
369 for (i = len - count; i < len; ++i)
370 result->value.character.string[i] = ' ';
371
372 result->value.character.string[len] = '\0'; /* For debugger */
373
374 return result;
375 }
376
377
378 gfc_expr *
379 gfc_simplify_adjustr (gfc_expr *e)
380 {
381 gfc_expr *result;
382 int count, i, len;
383 gfc_char_t ch;
384
385 if (e->expr_type != EXPR_CONSTANT)
386 return NULL;
387
388 len = e->value.character.length;
389
390 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
391
392 result->value.character.length = len;
393 result->value.character.string = gfc_get_wide_string (len + 1);
394
395 for (count = 0, i = len - 1; i >= 0; --i)
396 {
397 ch = e->value.character.string[i];
398 if (ch != ' ')
399 break;
400 ++count;
401 }
402
403 for (i = 0; i < count; ++i)
404 result->value.character.string[i] = ' ';
405
406 for (i = count; i < len; ++i)
407 result->value.character.string[i] = e->value.character.string[i - count];
408
409 result->value.character.string[len] = '\0'; /* For debugger */
410
411 return result;
412 }
413
414
415 gfc_expr *
416 gfc_simplify_aimag (gfc_expr *e)
417 {
418 gfc_expr *result;
419
420 if (e->expr_type != EXPR_CONSTANT)
421 return NULL;
422
423 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
424 mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
425
426 return range_check (result, "AIMAG");
427 }
428
429
430 gfc_expr *
431 gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
432 {
433 gfc_expr *rtrunc, *result;
434 int kind;
435
436 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
437 if (kind == -1)
438 return &gfc_bad_expr;
439
440 if (e->expr_type != EXPR_CONSTANT)
441 return NULL;
442
443 rtrunc = gfc_copy_expr (e);
444
445 mpfr_trunc (rtrunc->value.real, e->value.real);
446
447 result = gfc_real2real (rtrunc, kind);
448 gfc_free_expr (rtrunc);
449
450 return range_check (result, "AINT");
451 }
452
453
454 gfc_expr *
455 gfc_simplify_dint (gfc_expr *e)
456 {
457 gfc_expr *rtrunc, *result;
458
459 if (e->expr_type != EXPR_CONSTANT)
460 return NULL;
461
462 rtrunc = gfc_copy_expr (e);
463
464 mpfr_trunc (rtrunc->value.real, e->value.real);
465
466 result = gfc_real2real (rtrunc, gfc_default_double_kind);
467 gfc_free_expr (rtrunc);
468
469 return range_check (result, "DINT");
470 }
471
472
473 gfc_expr *
474 gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
475 {
476 gfc_expr *result;
477 int kind;
478
479 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
480 if (kind == -1)
481 return &gfc_bad_expr;
482
483 if (e->expr_type != EXPR_CONSTANT)
484 return NULL;
485
486 result = gfc_constant_result (e->ts.type, kind, &e->where);
487
488 mpfr_round (result->value.real, e->value.real);
489
490 return range_check (result, "ANINT");
491 }
492
493
494 gfc_expr *
495 gfc_simplify_and (gfc_expr *x, gfc_expr *y)
496 {
497 gfc_expr *result;
498 int kind;
499
500 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
501 return NULL;
502
503 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
504 if (x->ts.type == BT_INTEGER)
505 {
506 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
507 mpz_and (result->value.integer, x->value.integer, y->value.integer);
508 return range_check (result, "AND");
509 }
510 else /* BT_LOGICAL */
511 {
512 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
513 result->value.logical = x->value.logical && y->value.logical;
514 return result;
515 }
516
517 }
518
519
520 gfc_expr *
521 gfc_simplify_dnint (gfc_expr *e)
522 {
523 gfc_expr *result;
524
525 if (e->expr_type != EXPR_CONSTANT)
526 return NULL;
527
528 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
529
530 mpfr_round (result->value.real, e->value.real);
531
532 return range_check (result, "DNINT");
533 }
534
535
536 gfc_expr *
537 gfc_simplify_asin (gfc_expr *x)
538 {
539 gfc_expr *result;
540
541 if (x->expr_type != EXPR_CONSTANT)
542 return NULL;
543
544 if (mpfr_cmp_si (x->value.real, 1) > 0
545 || mpfr_cmp_si (x->value.real, -1) < 0)
546 {
547 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
548 &x->where);
549 return &gfc_bad_expr;
550 }
551
552 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
553
554 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
555
556 return range_check (result, "ASIN");
557 }
558
559
560 gfc_expr *
561 gfc_simplify_asinh (gfc_expr *x)
562 {
563 gfc_expr *result;
564
565 if (x->expr_type != EXPR_CONSTANT)
566 return NULL;
567
568 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
569
570 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
571
572 return range_check (result, "ASINH");
573 }
574
575
576 gfc_expr *
577 gfc_simplify_atan (gfc_expr *x)
578 {
579 gfc_expr *result;
580
581 if (x->expr_type != EXPR_CONSTANT)
582 return NULL;
583
584 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
585
586 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
587
588 return range_check (result, "ATAN");
589 }
590
591
592 gfc_expr *
593 gfc_simplify_atanh (gfc_expr *x)
594 {
595 gfc_expr *result;
596
597 if (x->expr_type != EXPR_CONSTANT)
598 return NULL;
599
600 if (mpfr_cmp_si (x->value.real, 1) >= 0
601 || mpfr_cmp_si (x->value.real, -1) <= 0)
602 {
603 gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
604 &x->where);
605 return &gfc_bad_expr;
606 }
607
608 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
609
610 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
611
612 return range_check (result, "ATANH");
613 }
614
615
616 gfc_expr *
617 gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
618 {
619 gfc_expr *result;
620
621 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
622 return NULL;
623
624 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
625
626 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
627 {
628 gfc_error ("If first argument of ATAN2 %L is zero, then the "
629 "second argument must not be zero", &x->where);
630 gfc_free_expr (result);
631 return &gfc_bad_expr;
632 }
633
634 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
635
636 return range_check (result, "ATAN2");
637 }
638
639
640 gfc_expr *
641 gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
642 {
643 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
644 gfc_expr *result;
645
646 if (x->expr_type != EXPR_CONSTANT)
647 return NULL;
648
649 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
650 gfc_set_model_kind (x->ts.kind);
651 mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
652
653 return range_check (result, "BESSEL_J0");
654 #else
655 return NULL;
656 #endif
657 }
658
659
660 gfc_expr *
661 gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
662 {
663 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
664 gfc_expr *result;
665
666 if (x->expr_type != EXPR_CONSTANT)
667 return NULL;
668
669 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
670 gfc_set_model_kind (x->ts.kind);
671 mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
672
673 return range_check (result, "BESSEL_J1");
674 #else
675 return NULL;
676 #endif
677 }
678
679
680 gfc_expr *
681 gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
682 gfc_expr *x ATTRIBUTE_UNUSED)
683 {
684 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
685 gfc_expr *result;
686 long n;
687
688 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
689 return NULL;
690
691 n = mpz_get_si (order->value.integer);
692 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
693 gfc_set_model_kind (x->ts.kind);
694 mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
695
696 return range_check (result, "BESSEL_JN");
697 #else
698 return NULL;
699 #endif
700 }
701
702
703 gfc_expr *
704 gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
705 {
706 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
707 gfc_expr *result;
708
709 if (x->expr_type != EXPR_CONSTANT)
710 return NULL;
711
712 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
713 gfc_set_model_kind (x->ts.kind);
714 mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
715
716 return range_check (result, "BESSEL_Y0");
717 #else
718 return NULL;
719 #endif
720 }
721
722
723 gfc_expr *
724 gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
725 {
726 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
727 gfc_expr *result;
728
729 if (x->expr_type != EXPR_CONSTANT)
730 return NULL;
731
732 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
733 gfc_set_model_kind (x->ts.kind);
734 mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
735
736 return range_check (result, "BESSEL_Y1");
737 #else
738 return NULL;
739 #endif
740 }
741
742
743 gfc_expr *
744 gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
745 gfc_expr *x ATTRIBUTE_UNUSED)
746 {
747 #if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
748 gfc_expr *result;
749 long n;
750
751 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
752 return NULL;
753
754 n = mpz_get_si (order->value.integer);
755 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
756 gfc_set_model_kind (x->ts.kind);
757 mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
758
759 return range_check (result, "BESSEL_YN");
760 #else
761 return NULL;
762 #endif
763 }
764
765
766 gfc_expr *
767 gfc_simplify_bit_size (gfc_expr *e)
768 {
769 gfc_expr *result;
770 int i;
771
772 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
773 result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
774 mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
775
776 return result;
777 }
778
779
780 gfc_expr *
781 gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
782 {
783 int b;
784
785 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
786 return NULL;
787
788 if (gfc_extract_int (bit, &b) != NULL || b < 0)
789 return gfc_logical_expr (0, &e->where);
790
791 return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
792 }
793
794
795 gfc_expr *
796 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
797 {
798 gfc_expr *ceil, *result;
799 int kind;
800
801 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
802 if (kind == -1)
803 return &gfc_bad_expr;
804
805 if (e->expr_type != EXPR_CONSTANT)
806 return NULL;
807
808 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
809
810 ceil = gfc_copy_expr (e);
811
812 mpfr_ceil (ceil->value.real, e->value.real);
813 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
814
815 gfc_free_expr (ceil);
816
817 return range_check (result, "CEILING");
818 }
819
820
821 gfc_expr *
822 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
823 {
824 gfc_expr *result;
825 int c, kind;
826 const char *ch;
827
828 kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
829 if (kind == -1)
830 return &gfc_bad_expr;
831
832 if (e->expr_type != EXPR_CONSTANT)
833 return NULL;
834
835 ch = gfc_extract_int (e, &c);
836
837 if (ch != NULL)
838 gfc_internal_error ("gfc_simplify_char: %s", ch);
839
840 if (c < 0 || c > UCHAR_MAX)
841 gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
842 &e->where);
843
844 result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
845
846 result->value.character.length = 1;
847 result->value.character.string = gfc_get_wide_string (2);
848
849 result->value.character.string[0] = c;
850 result->value.character.string[1] = '\0'; /* For debugger */
851
852 return result;
853 }
854
855
856 /* Common subroutine for simplifying CMPLX and DCMPLX. */
857
858 static gfc_expr *
859 simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
860 {
861 gfc_expr *result;
862
863 result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
864
865 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
866
867 switch (x->ts.type)
868 {
869 case BT_INTEGER:
870 if (!x->is_boz)
871 mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
872 break;
873
874 case BT_REAL:
875 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
876 break;
877
878 case BT_COMPLEX:
879 mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
880 mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
881 break;
882
883 default:
884 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
885 }
886
887 if (y != NULL)
888 {
889 switch (y->ts.type)
890 {
891 case BT_INTEGER:
892 if (!y->is_boz)
893 mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
894 break;
895
896 case BT_REAL:
897 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
898 break;
899
900 default:
901 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
902 }
903 }
904
905 /* Handle BOZ. */
906 if (x->is_boz)
907 {
908 gfc_typespec ts;
909 gfc_clear_ts (&ts);
910 ts.kind = result->ts.kind;
911 ts.type = BT_REAL;
912 if (!gfc_convert_boz (x, &ts))
913 return &gfc_bad_expr;
914 mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
915 }
916
917 if (y && y->is_boz)
918 {
919 gfc_typespec ts;
920 gfc_clear_ts (&ts);
921 ts.kind = result->ts.kind;
922 ts.type = BT_REAL;
923 if (!gfc_convert_boz (y, &ts))
924 return &gfc_bad_expr;
925 mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
926 }
927
928 return range_check (result, name);
929 }
930
931
932 /* Function called when we won't simplify an expression like CMPLX (or
933 COMPLEX or DCMPLX) but still want to convert BOZ arguments. */
934
935 static gfc_expr *
936 only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
937 {
938 if (x->is_boz)
939 {
940 gfc_typespec ts;
941 gfc_clear_ts (&ts);
942 ts.type = BT_REAL;
943 ts.kind = kind;
944 if (!gfc_convert_boz (x, &ts))
945 return &gfc_bad_expr;
946 }
947
948 if (y && y->is_boz)
949 {
950 gfc_typespec ts;
951 gfc_clear_ts (&ts);
952 ts.type = BT_REAL;
953 ts.kind = kind;
954 if (!gfc_convert_boz (y, &ts))
955 return &gfc_bad_expr;
956 }
957
958 return NULL;
959 }
960
961
962 gfc_expr *
963 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
964 {
965 int kind;
966
967 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
968 if (kind == -1)
969 return &gfc_bad_expr;
970
971 if (x->expr_type != EXPR_CONSTANT
972 || (y != NULL && y->expr_type != EXPR_CONSTANT))
973 return only_convert_cmplx_boz (x, y, kind);
974
975 return simplify_cmplx ("CMPLX", x, y, kind);
976 }
977
978
979 gfc_expr *
980 gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
981 {
982 int kind;
983
984 if (x->ts.type == BT_INTEGER)
985 {
986 if (y->ts.type == BT_INTEGER)
987 kind = gfc_default_real_kind;
988 else
989 kind = y->ts.kind;
990 }
991 else
992 {
993 if (y->ts.type == BT_REAL)
994 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
995 else
996 kind = x->ts.kind;
997 }
998
999 if (x->expr_type != EXPR_CONSTANT
1000 || (y != NULL && y->expr_type != EXPR_CONSTANT))
1001 return only_convert_cmplx_boz (x, y, kind);
1002
1003 return simplify_cmplx ("COMPLEX", x, y, kind);
1004 }
1005
1006
1007 gfc_expr *
1008 gfc_simplify_conjg (gfc_expr *e)
1009 {
1010 gfc_expr *result;
1011
1012 if (e->expr_type != EXPR_CONSTANT)
1013 return NULL;
1014
1015 result = gfc_copy_expr (e);
1016 mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
1017
1018 return range_check (result, "CONJG");
1019 }
1020
1021
1022 gfc_expr *
1023 gfc_simplify_cos (gfc_expr *x)
1024 {
1025 gfc_expr *result;
1026 mpfr_t xp, xq;
1027
1028 if (x->expr_type != EXPR_CONSTANT)
1029 return NULL;
1030
1031 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1032
1033 switch (x->ts.type)
1034 {
1035 case BT_REAL:
1036 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1037 break;
1038 case BT_COMPLEX:
1039 gfc_set_model_kind (x->ts.kind);
1040 mpfr_init (xp);
1041 mpfr_init (xq);
1042
1043 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
1044 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
1045 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
1046
1047 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
1048 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
1049 mpfr_mul (xp, xp, xq, GFC_RND_MODE);
1050 mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
1051
1052 mpfr_clear (xp);
1053 mpfr_clear (xq);
1054 break;
1055 default:
1056 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1057 }
1058
1059 return range_check (result, "COS");
1060
1061 }
1062
1063
1064 gfc_expr *
1065 gfc_simplify_cosh (gfc_expr *x)
1066 {
1067 gfc_expr *result;
1068
1069 if (x->expr_type != EXPR_CONSTANT)
1070 return NULL;
1071
1072 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1073
1074 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1075
1076 return range_check (result, "COSH");
1077 }
1078
1079
1080 gfc_expr *
1081 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
1082 {
1083
1084 if (x->expr_type != EXPR_CONSTANT
1085 || (y != NULL && y->expr_type != EXPR_CONSTANT))
1086 return only_convert_cmplx_boz (x, y, gfc_default_double_kind);
1087
1088 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
1089 }
1090
1091
1092 gfc_expr *
1093 gfc_simplify_dble (gfc_expr *e)
1094 {
1095 gfc_expr *result;
1096
1097 if (e->expr_type != EXPR_CONSTANT)
1098 return NULL;
1099
1100 switch (e->ts.type)
1101 {
1102 case BT_INTEGER:
1103 if (!e->is_boz)
1104 result = gfc_int2real (e, gfc_default_double_kind);
1105 break;
1106
1107 case BT_REAL:
1108 result = gfc_real2real (e, gfc_default_double_kind);
1109 break;
1110
1111 case BT_COMPLEX:
1112 result = gfc_complex2real (e, gfc_default_double_kind);
1113 break;
1114
1115 default:
1116 gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
1117 }
1118
1119 if (e->ts.type == BT_INTEGER && e->is_boz)
1120 {
1121 gfc_typespec ts;
1122 gfc_clear_ts (&ts);
1123 ts.type = BT_REAL;
1124 ts.kind = gfc_default_double_kind;
1125 result = gfc_copy_expr (e);
1126 if (!gfc_convert_boz (result, &ts))
1127 {
1128 gfc_free_expr (result);
1129 return &gfc_bad_expr;
1130 }
1131 }
1132
1133 return range_check (result, "DBLE");
1134 }
1135
1136
1137 gfc_expr *
1138 gfc_simplify_digits (gfc_expr *x)
1139 {
1140 int i, digits;
1141
1142 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1143 switch (x->ts.type)
1144 {
1145 case BT_INTEGER:
1146 digits = gfc_integer_kinds[i].digits;
1147 break;
1148
1149 case BT_REAL:
1150 case BT_COMPLEX:
1151 digits = gfc_real_kinds[i].digits;
1152 break;
1153
1154 default:
1155 gcc_unreachable ();
1156 }
1157
1158 return gfc_int_expr (digits);
1159 }
1160
1161
1162 gfc_expr *
1163 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
1164 {
1165 gfc_expr *result;
1166 int kind;
1167
1168 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1169 return NULL;
1170
1171 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1172 result = gfc_constant_result (x->ts.type, kind, &x->where);
1173
1174 switch (x->ts.type)
1175 {
1176 case BT_INTEGER:
1177 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1178 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1179 else
1180 mpz_set_ui (result->value.integer, 0);
1181
1182 break;
1183
1184 case BT_REAL:
1185 if (mpfr_cmp (x->value.real, y->value.real) > 0)
1186 mpfr_sub (result->value.real, x->value.real, y->value.real,
1187 GFC_RND_MODE);
1188 else
1189 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1190
1191 break;
1192
1193 default:
1194 gfc_internal_error ("gfc_simplify_dim(): Bad type");
1195 }
1196
1197 return range_check (result, "DIM");
1198 }
1199
1200
1201 gfc_expr *
1202 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
1203 {
1204 gfc_expr *a1, *a2, *result;
1205
1206 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1207 return NULL;
1208
1209 result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
1210
1211 a1 = gfc_real2real (x, gfc_default_double_kind);
1212 a2 = gfc_real2real (y, gfc_default_double_kind);
1213
1214 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
1215
1216 gfc_free_expr (a1);
1217 gfc_free_expr (a2);
1218
1219 return range_check (result, "DPROD");
1220 }
1221
1222
1223 gfc_expr *
1224 gfc_simplify_erf (gfc_expr *x)
1225 {
1226 gfc_expr *result;
1227
1228 if (x->expr_type != EXPR_CONSTANT)
1229 return NULL;
1230
1231 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1232
1233 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1234
1235 return range_check (result, "ERF");
1236 }
1237
1238
1239 gfc_expr *
1240 gfc_simplify_erfc (gfc_expr *x)
1241 {
1242 gfc_expr *result;
1243
1244 if (x->expr_type != EXPR_CONSTANT)
1245 return NULL;
1246
1247 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1248
1249 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1250
1251 return range_check (result, "ERFC");
1252 }
1253
1254
1255 gfc_expr *
1256 gfc_simplify_epsilon (gfc_expr *e)
1257 {
1258 gfc_expr *result;
1259 int i;
1260
1261 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1262
1263 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
1264
1265 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
1266
1267 return range_check (result, "EPSILON");
1268 }
1269
1270
1271 gfc_expr *
1272 gfc_simplify_exp (gfc_expr *x)
1273 {
1274 gfc_expr *result;
1275 mpfr_t xp, xq;
1276
1277 if (x->expr_type != EXPR_CONSTANT)
1278 return NULL;
1279
1280 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1281
1282 switch (x->ts.type)
1283 {
1284 case BT_REAL:
1285 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
1286 break;
1287
1288 case BT_COMPLEX:
1289 gfc_set_model_kind (x->ts.kind);
1290 mpfr_init (xp);
1291 mpfr_init (xq);
1292 mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
1293 mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
1294 mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
1295 mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
1296 mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
1297 mpfr_clear (xp);
1298 mpfr_clear (xq);
1299 break;
1300
1301 default:
1302 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
1303 }
1304
1305 return range_check (result, "EXP");
1306 }
1307
1308 gfc_expr *
1309 gfc_simplify_exponent (gfc_expr *x)
1310 {
1311 int i;
1312 gfc_expr *result;
1313
1314 if (x->expr_type != EXPR_CONSTANT)
1315 return NULL;
1316
1317 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
1318 &x->where);
1319
1320 gfc_set_model (x->value.real);
1321
1322 if (mpfr_sgn (x->value.real) == 0)
1323 {
1324 mpz_set_ui (result->value.integer, 0);
1325 return result;
1326 }
1327
1328 i = (int) mpfr_get_exp (x->value.real);
1329 mpz_set_si (result->value.integer, i);
1330
1331 return range_check (result, "EXPONENT");
1332 }
1333
1334
1335 gfc_expr *
1336 gfc_simplify_float (gfc_expr *a)
1337 {
1338 gfc_expr *result;
1339
1340 if (a->expr_type != EXPR_CONSTANT)
1341 return NULL;
1342
1343 if (a->is_boz)
1344 {
1345 gfc_typespec ts;
1346 gfc_clear_ts (&ts);
1347
1348 ts.type = BT_REAL;
1349 ts.kind = gfc_default_real_kind;
1350
1351 result = gfc_copy_expr (a);
1352 if (!gfc_convert_boz (result, &ts))
1353 {
1354 gfc_free_expr (result);
1355 return &gfc_bad_expr;
1356 }
1357 }
1358 else
1359 result = gfc_int2real (a, gfc_default_real_kind);
1360 return range_check (result, "FLOAT");
1361 }
1362
1363
1364 gfc_expr *
1365 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
1366 {
1367 gfc_expr *result;
1368 mpfr_t floor;
1369 int kind;
1370
1371 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
1372 if (kind == -1)
1373 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
1374
1375 if (e->expr_type != EXPR_CONSTANT)
1376 return NULL;
1377
1378 result = gfc_constant_result (BT_INTEGER, kind, &e->where);
1379
1380 gfc_set_model_kind (kind);
1381 mpfr_init (floor);
1382 mpfr_floor (floor, e->value.real);
1383
1384 gfc_mpfr_to_mpz (result->value.integer, floor);
1385
1386 mpfr_clear (floor);
1387
1388 return range_check (result, "FLOOR");
1389 }
1390
1391
1392 gfc_expr *
1393 gfc_simplify_fraction (gfc_expr *x)
1394 {
1395 gfc_expr *result;
1396 mpfr_t absv, exp, pow2;
1397
1398 if (x->expr_type != EXPR_CONSTANT)
1399 return NULL;
1400
1401 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
1402
1403 gfc_set_model_kind (x->ts.kind);
1404
1405 if (mpfr_sgn (x->value.real) == 0)
1406 {
1407 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
1408 return result;
1409 }
1410
1411 mpfr_init (exp);
1412 mpfr_init (absv);
1413 mpfr_init (pow2);
1414
1415 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
1416 mpfr_log2 (exp, absv, GFC_RND_MODE);
1417
1418 mpfr_trunc (exp, exp);
1419 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
1420
1421 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
1422
1423 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
1424
1425 mpfr_clear (exp);
1426 mpfr_clear (absv);
1427 mpfr_clear (pow2);
1428
1429 return range_check (result, "FRACTION");
1430 }
1431
1432
1433 gfc_expr *
1434 gfc_simplify_gamma (gfc_expr *x)
1435 {
1436 gfc_expr *result;
1437
1438 if (x->expr_type != EXPR_CONSTANT)
1439 return NULL;
1440
1441 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1442
1443 gfc_set_model_kind (x->ts.kind);
1444
1445 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
1446
1447 return range_check (result, "GAMMA");
1448 }
1449
1450
1451 gfc_expr *
1452 gfc_simplify_huge (gfc_expr *e)
1453 {
1454 gfc_expr *result;
1455 int i;
1456
1457 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1458
1459 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
1460
1461 switch (e->ts.type)
1462 {
1463 case BT_INTEGER:
1464 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
1465 break;
1466
1467 case BT_REAL:
1468 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
1469 break;
1470
1471 default:
1472 gcc_unreachable ();
1473 }
1474
1475 return result;
1476 }
1477
1478
1479 gfc_expr *
1480 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
1481 {
1482 gfc_expr *result;
1483
1484 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1485 return NULL;
1486
1487 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1488 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
1489 return range_check (result, "HYPOT");
1490 }
1491
1492
1493 /* We use the processor's collating sequence, because all
1494 systems that gfortran currently works on are ASCII. */
1495
1496 gfc_expr *
1497 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
1498 {
1499 gfc_expr *result;
1500 gfc_char_t index;
1501
1502 if (e->expr_type != EXPR_CONSTANT)
1503 return NULL;
1504
1505 if (e->value.character.length != 1)
1506 {
1507 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
1508 return &gfc_bad_expr;
1509 }
1510
1511 index = e->value.character.string[0];
1512
1513 if (gfc_option.warn_surprising && index > 127)
1514 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
1515 &e->where);
1516
1517 if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
1518 return &gfc_bad_expr;
1519
1520 result->where = e->where;
1521
1522 return range_check (result, "IACHAR");
1523 }
1524
1525
1526 gfc_expr *
1527 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
1528 {
1529 gfc_expr *result;
1530
1531 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1532 return NULL;
1533
1534 result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
1535
1536 mpz_and (result->value.integer, x->value.integer, y->value.integer);
1537
1538 return range_check (result, "IAND");
1539 }
1540
1541
1542 gfc_expr *
1543 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
1544 {
1545 gfc_expr *result;
1546 int k, pos;
1547
1548 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1549 return NULL;
1550
1551 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1552 {
1553 gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
1554 return &gfc_bad_expr;
1555 }
1556
1557 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1558
1559 if (pos >= gfc_integer_kinds[k].bit_size)
1560 {
1561 gfc_error ("Second argument of IBCLR exceeds bit size at %L",
1562 &y->where);
1563 return &gfc_bad_expr;
1564 }
1565
1566 result = gfc_copy_expr (x);
1567
1568 convert_mpz_to_unsigned (result->value.integer,
1569 gfc_integer_kinds[k].bit_size);
1570
1571 mpz_clrbit (result->value.integer, pos);
1572
1573 convert_mpz_to_signed (result->value.integer,
1574 gfc_integer_kinds[k].bit_size);
1575
1576 return result;
1577 }
1578
1579
1580 gfc_expr *
1581 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
1582 {
1583 gfc_expr *result;
1584 int pos, len;
1585 int i, k, bitsize;
1586 int *bits;
1587
1588 if (x->expr_type != EXPR_CONSTANT
1589 || y->expr_type != EXPR_CONSTANT
1590 || z->expr_type != EXPR_CONSTANT)
1591 return NULL;
1592
1593 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1594 {
1595 gfc_error ("Invalid second argument of IBITS at %L", &y->where);
1596 return &gfc_bad_expr;
1597 }
1598
1599 if (gfc_extract_int (z, &len) != NULL || len < 0)
1600 {
1601 gfc_error ("Invalid third argument of IBITS at %L", &z->where);
1602 return &gfc_bad_expr;
1603 }
1604
1605 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
1606
1607 bitsize = gfc_integer_kinds[k].bit_size;
1608
1609 if (pos + len > bitsize)
1610 {
1611 gfc_error ("Sum of second and third arguments of IBITS exceeds "
1612 "bit size at %L", &y->where);
1613 return &gfc_bad_expr;
1614 }
1615
1616 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
1617 convert_mpz_to_unsigned (result->value.integer,
1618 gfc_integer_kinds[k].bit_size);
1619
1620 bits = gfc_getmem (bitsize * sizeof (int));
1621
1622 for (i = 0; i < bitsize; i++)
1623 bits[i] = 0;
1624
1625 for (i = 0; i < len; i++)
1626 bits[i] = mpz_tstbit (x->value.integer, i + pos);
1627
1628 for (i = 0; i < bitsize; i++)
1629 {
1630 if (bits[i] == 0)
1631 mpz_clrbit (result->value.integer, i);
1632 else if (bits[i] == 1)
1633 mpz_setbit (result->value.integer, i);
1634 else
1635 gfc_internal_error ("IBITS: Bad bit");
1636 }
1637
1638 gfc_free (bits);
1639
1640 convert_mpz_to_signed (result->value.integer,
1641 gfc_integer_kinds[k].bit_size);
1642
1643 return result;
1644 }
1645
1646
1647 gfc_expr *
1648 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
1649 {
1650 gfc_expr *result;
1651 int k, pos;
1652
1653 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1654 return NULL;
1655
1656 if (gfc_extract_int (y, &pos) != NULL || pos < 0)
1657 {
1658 gfc_error ("Invalid second argument of IBSET at %L", &y->where);
1659 return &gfc_bad_expr;
1660 }
1661
1662 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
1663
1664 if (pos >= gfc_integer_kinds[k].bit_size)
1665 {
1666 gfc_error ("Second argument of IBSET exceeds bit size at %L",
1667 &y->where);
1668 return &gfc_bad_expr;
1669 }
1670
1671 result = gfc_copy_expr (x);
1672
1673 convert_mpz_to_unsigned (result->value.integer,
1674 gfc_integer_kinds[k].bit_size);
1675
1676 mpz_setbit (result->value.integer, pos);
1677
1678 convert_mpz_to_signed (result->value.integer,
1679 gfc_integer_kinds[k].bit_size);
1680
1681 return result;
1682 }
1683
1684
1685 gfc_expr *
1686 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
1687 {
1688 gfc_expr *result;
1689 gfc_char_t index;
1690
1691 if (e->expr_type != EXPR_CONSTANT)
1692 return NULL;
1693
1694 if (e->value.character.length != 1)
1695 {
1696 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
1697 return &gfc_bad_expr;
1698 }
1699
1700 index = e->value.character.string[0];
1701 if (index > UCHAR_MAX)
1702 gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
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;
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 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org