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