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