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