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