?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* Merge from mainline
[official-gcc.git] / gcc / fortran / simplify.c
blob894903bdd2e815786fb5d05f905a00739bfbb2c9
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 result = gfc_get_expr ();
2532 result->expr_type = EXPR_NULL;
2533
2534 if (mold == NULL)
2535 result->ts.type = BT_UNKNOWN;
2536 else
2537 {
2538 result->ts = mold->ts;
2539 result->where = mold->where;
2540 }
2541
2542 return result;
2543 }
2544
2545
2546 gfc_expr *
2547 gfc_simplify_or (gfc_expr * x, gfc_expr * y)
2548 {
2549 gfc_expr *result;
2550 int kind;
2551
2552 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2553 return NULL;
2554
2555 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2556 if (x->ts.type == BT_INTEGER)
2557 {
2558 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
2559 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
2560 }
2561 else /* BT_LOGICAL */
2562 {
2563 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
2564 result->value.logical = x->value.logical || y->value.logical;
2565 }
2566
2567 return range_check (result, "OR");
2568 }
2569
2570
2571 gfc_expr *
2572 gfc_simplify_precision (gfc_expr * e)
2573 {
2574 gfc_expr *result;
2575 int i;
2576
2577 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2578
2579 result = gfc_int_expr (gfc_real_kinds[i].precision);
2580 result->where = e->where;
2581
2582 return result;
2583 }
2584
2585
2586 gfc_expr *
2587 gfc_simplify_radix (gfc_expr * e)
2588 {
2589 gfc_expr *result;
2590 int i;
2591
2592 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2593 switch (e->ts.type)
2594 {
2595 case BT_INTEGER:
2596 i = gfc_integer_kinds[i].radix;
2597 break;
2598
2599 case BT_REAL:
2600 i = gfc_real_kinds[i].radix;
2601 break;
2602
2603 default:
2604 gcc_unreachable ();
2605 }
2606
2607 result = gfc_int_expr (i);
2608 result->where = e->where;
2609
2610 return result;
2611 }
2612
2613
2614 gfc_expr *
2615 gfc_simplify_range (gfc_expr * e)
2616 {
2617 gfc_expr *result;
2618 int i;
2619 long j;
2620
2621 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2622
2623 switch (e->ts.type)
2624 {
2625 case BT_INTEGER:
2626 j = gfc_integer_kinds[i].range;
2627 break;
2628
2629 case BT_REAL:
2630 case BT_COMPLEX:
2631 j = gfc_real_kinds[i].range;
2632 break;
2633
2634 default:
2635 gcc_unreachable ();
2636 }
2637
2638 result = gfc_int_expr (j);
2639 result->where = e->where;
2640
2641 return result;
2642 }
2643
2644
2645 gfc_expr *
2646 gfc_simplify_real (gfc_expr * e, gfc_expr * k)
2647 {
2648 gfc_expr *result;
2649 int kind;
2650
2651 if (e->ts.type == BT_COMPLEX)
2652 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
2653 else
2654 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
2655
2656 if (kind == -1)
2657 return &gfc_bad_expr;
2658
2659 if (e->expr_type != EXPR_CONSTANT)
2660 return NULL;
2661
2662 switch (e->ts.type)
2663 {
2664 case BT_INTEGER:
2665 result = gfc_int2real (e, kind);
2666 break;
2667
2668 case BT_REAL:
2669 result = gfc_real2real (e, kind);
2670 break;
2671
2672 case BT_COMPLEX:
2673 result = gfc_complex2real (e, kind);
2674 break;
2675
2676 default:
2677 gfc_internal_error ("bad type in REAL");
2678 /* Not reached */
2679 }
2680
2681 return range_check (result, "REAL");
2682 }
2683
2684
2685 gfc_expr *
2686 gfc_simplify_realpart (gfc_expr * e)
2687 {
2688 gfc_expr *result;
2689
2690 if (e->expr_type != EXPR_CONSTANT)
2691 return NULL;
2692
2693 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
2694 mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
2695
2696 return range_check (result, "REALPART");
2697 }
2698
2699 gfc_expr *
2700 gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
2701 {
2702 gfc_expr *result;
2703 int i, j, len, ncopies, nlen;
2704
2705 if (e->expr_type != EXPR_CONSTANT || n->expr_type != EXPR_CONSTANT)
2706 return NULL;
2707
2708 if (n != NULL && (gfc_extract_int (n, &ncopies) != NULL || ncopies < 0))
2709 {
2710 gfc_error ("Invalid second argument of REPEAT at %L", &n->where);
2711 return &gfc_bad_expr;
2712 }
2713
2714 len = e->value.character.length;
2715 nlen = ncopies * len;
2716
2717 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
2718
2719 if (ncopies == 0)
2720 {
2721 result->value.character.string = gfc_getmem (1);
2722 result->value.character.length = 0;
2723 result->value.character.string[0] = '\0';
2724 return result;
2725 }
2726
2727 result->value.character.length = nlen;
2728 result->value.character.string = gfc_getmem (nlen + 1);
2729
2730 for (i = 0; i < ncopies; i++)
2731 for (j = 0; j < len; j++)
2732 result->value.character.string[j + i * len] =
2733 e->value.character.string[j];
2734
2735 result->value.character.string[nlen] = '\0'; /* For debugger */
2736 return result;
2737 }
2738
2739
2740 /* This one is a bear, but mainly has to do with shuffling elements. */
2741
2742 gfc_expr *
2743 gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp,
2744 gfc_expr * pad, gfc_expr * order_exp)
2745 {
2746
2747 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
2748 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
2749 gfc_constructor *head, *tail;
2750 mpz_t index, size;
2751 unsigned long j;
2752 size_t nsource;
2753 gfc_expr *e;
2754
2755 /* Unpack the shape array. */
2756 if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
2757 return NULL;
2758
2759 if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
2760 return NULL;
2761
2762 if (pad != NULL
2763 && (pad->expr_type != EXPR_ARRAY
2764 || !gfc_is_constant_expr (pad)))
2765 return NULL;
2766
2767 if (order_exp != NULL
2768 && (order_exp->expr_type != EXPR_ARRAY
2769 || !gfc_is_constant_expr (order_exp)))
2770 return NULL;
2771
2772 mpz_init (index);
2773 rank = 0;
2774 head = tail = NULL;
2775
2776 for (;;)
2777 {
2778 e = gfc_get_array_element (shape_exp, rank);
2779 if (e == NULL)
2780 break;
2781
2782 if (gfc_extract_int (e, &shape[rank]) != NULL)
2783 {
2784 gfc_error ("Integer too large in shape specification at %L",
2785 &e->where);
2786 gfc_free_expr (e);
2787 goto bad_reshape;
2788 }
2789
2790 gfc_free_expr (e);
2791
2792 if (rank >= GFC_MAX_DIMENSIONS)
2793 {
2794 gfc_error ("Too many dimensions in shape specification for RESHAPE "
2795 "at %L", &e->where);
2796
2797 goto bad_reshape;
2798 }
2799
2800 if (shape[rank] < 0)
2801 {
2802 gfc_error ("Shape specification at %L cannot be negative",
2803 &e->where);
2804 goto bad_reshape;
2805 }
2806
2807 rank++;
2808 }
2809
2810 if (rank == 0)
2811 {
2812 gfc_error ("Shape specification at %L cannot be the null array",
2813 &shape_exp->where);
2814 goto bad_reshape;
2815 }
2816
2817 /* Now unpack the order array if present. */
2818 if (order_exp == NULL)
2819 {
2820 for (i = 0; i < rank; i++)
2821 order[i] = i;
2822
2823 }
2824 else
2825 {
2826
2827 for (i = 0; i < rank; i++)
2828 x[i] = 0;
2829
2830 for (i = 0; i < rank; i++)
2831 {
2832 e = gfc_get_array_element (order_exp, i);
2833 if (e == NULL)
2834 {
2835 gfc_error
2836 ("ORDER parameter of RESHAPE at %L is not the same size "
2837 "as SHAPE parameter", &order_exp->where);
2838 goto bad_reshape;
2839 }
2840
2841 if (gfc_extract_int (e, &order[i]) != NULL)
2842 {
2843 gfc_error ("Error in ORDER parameter of RESHAPE at %L",
2844 &e->where);
2845 gfc_free_expr (e);
2846 goto bad_reshape;
2847 }
2848
2849 gfc_free_expr (e);
2850
2851 if (order[i] < 1 || order[i] > rank)
2852 {
2853 gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
2854 &e->where);
2855 goto bad_reshape;
2856 }
2857
2858 order[i]--;
2859
2860 if (x[order[i]])
2861 {
2862 gfc_error ("Invalid permutation in ORDER parameter at %L",
2863 &e->where);
2864 goto bad_reshape;
2865 }
2866
2867 x[order[i]] = 1;
2868 }
2869 }
2870
2871 /* Count the elements in the source and padding arrays. */
2872
2873 npad = 0;
2874 if (pad != NULL)
2875 {
2876 gfc_array_size (pad, &size);
2877 npad = mpz_get_ui (size);
2878 mpz_clear (size);
2879 }
2880
2881 gfc_array_size (source, &size);
2882 nsource = mpz_get_ui (size);
2883 mpz_clear (size);
2884
2885 /* If it weren't for that pesky permutation we could just loop
2886 through the source and round out any shortage with pad elements.
2887 But no, someone just had to have the compiler do something the
2888 user should be doing. */
2889
2890 for (i = 0; i < rank; i++)
2891 x[i] = 0;
2892
2893 for (;;)
2894 {
2895 /* Figure out which element to extract. */
2896 mpz_set_ui (index, 0);
2897
2898 for (i = rank - 1; i >= 0; i--)
2899 {
2900 mpz_add_ui (index, index, x[order[i]]);
2901 if (i != 0)
2902 mpz_mul_ui (index, index, shape[order[i - 1]]);
2903 }
2904
2905 if (mpz_cmp_ui (index, INT_MAX) > 0)
2906 gfc_internal_error ("Reshaped array too large at %L", &e->where);
2907
2908 j = mpz_get_ui (index);
2909
2910 if (j < nsource)
2911 e = gfc_get_array_element (source, j);
2912 else
2913 {
2914 j = j - nsource;
2915
2916 if (npad == 0)
2917 {
2918 gfc_error
2919 ("PAD parameter required for short SOURCE parameter at %L",
2920 &source->where);
2921 goto bad_reshape;
2922 }
2923
2924 j = j % npad;
2925 e = gfc_get_array_element (pad, j);
2926 }
2927
2928 if (head == NULL)
2929 head = tail = gfc_get_constructor ();
2930 else
2931 {
2932 tail->next = gfc_get_constructor ();
2933 tail = tail->next;
2934 }
2935
2936 if (e == NULL)
2937 goto bad_reshape;
2938
2939 tail->where = e->where;
2940 tail->expr = e;
2941
2942 /* Calculate the next element. */
2943 i = 0;
2944
2945 inc:
2946 if (++x[i] < shape[i])
2947 continue;
2948 x[i++] = 0;
2949 if (i < rank)
2950 goto inc;
2951
2952 break;
2953 }
2954
2955 mpz_clear (index);
2956
2957 e = gfc_get_expr ();
2958 e->where = source->where;
2959 e->expr_type = EXPR_ARRAY;
2960 e->value.constructor = head;
2961 e->shape = gfc_get_shape (rank);
2962
2963 for (i = 0; i < rank; i++)
2964 mpz_init_set_ui (e->shape[i], shape[i]);
2965
2966 e->ts = source->ts;
2967 e->rank = rank;
2968
2969 return e;
2970
2971 bad_reshape:
2972 gfc_free_constructor (head);
2973 mpz_clear (index);
2974 return &gfc_bad_expr;
2975 }
2976
2977
2978 gfc_expr *
2979 gfc_simplify_rrspacing (gfc_expr * x)
2980 {
2981 gfc_expr *result;
2982 mpfr_t absv, log2, exp, frac, pow2;
2983 int i, p;
2984
2985 if (x->expr_type != EXPR_CONSTANT)
2986 return NULL;
2987
2988 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2989
2990 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
2991
2992 p = gfc_real_kinds[i].digits;
2993
2994 gfc_set_model_kind (x->ts.kind);
2995
2996 if (mpfr_sgn (x->value.real) == 0)
2997 {
2998 mpfr_ui_div (result->value.real, 1, gfc_real_kinds[i].tiny, GFC_RND_MODE);
2999 return result;
3000 }
3001
3002 mpfr_init (log2);
3003 mpfr_init (absv);
3004 mpfr_init (frac);
3005 mpfr_init (pow2);
3006
3007 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3008 mpfr_log2 (log2, absv, GFC_RND_MODE);
3009
3010 mpfr_trunc (log2, log2);
3011 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3012
3013 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3014 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3015
3016 mpfr_mul_2exp (result->value.real, frac, (unsigned long)p, GFC_RND_MODE);
3017
3018 mpfr_clear (log2);
3019 mpfr_clear (absv);
3020 mpfr_clear (frac);
3021 mpfr_clear (pow2);
3022
3023 return range_check (result, "RRSPACING");
3024 }
3025
3026
3027 gfc_expr *
3028 gfc_simplify_scale (gfc_expr * x, gfc_expr * i)
3029 {
3030 int k, neg_flag, power, exp_range;
3031 mpfr_t scale, radix;
3032 gfc_expr *result;
3033
3034 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3035 return NULL;
3036
3037 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3038
3039 if (mpfr_sgn (x->value.real) == 0)
3040 {
3041 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3042 return result;
3043 }
3044
3045 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3046
3047 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
3048
3049 /* This check filters out values of i that would overflow an int. */
3050 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
3051 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
3052 {
3053 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
3054 return &gfc_bad_expr;
3055 }
3056
3057 /* Compute scale = radix ** power. */
3058 power = mpz_get_si (i->value.integer);
3059
3060 if (power >= 0)
3061 neg_flag = 0;
3062 else
3063 {
3064 neg_flag = 1;
3065 power = -power;
3066 }
3067
3068 gfc_set_model_kind (x->ts.kind);
3069 mpfr_init (scale);
3070 mpfr_init (radix);
3071 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
3072 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
3073
3074 if (neg_flag)
3075 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
3076 else
3077 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
3078
3079 mpfr_clear (scale);
3080 mpfr_clear (radix);
3081
3082 return range_check (result, "SCALE");
3083 }
3084
3085
3086 gfc_expr *
3087 gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b)
3088 {
3089 gfc_expr *result;
3090 int back;
3091 size_t i;
3092 size_t indx, len, lenc;
3093
3094 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
3095 return NULL;
3096
3097 if (b != NULL && b->value.logical != 0)
3098 back = 1;
3099 else
3100 back = 0;
3101
3102 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3103 &e->where);
3104
3105 len = e->value.character.length;
3106 lenc = c->value.character.length;
3107
3108 if (len == 0 || lenc == 0)
3109 {
3110 indx = 0;
3111 }
3112 else
3113 {
3114 if (back == 0)
3115 {
3116 indx =
3117 strcspn (e->value.character.string, c->value.character.string) + 1;
3118 if (indx > len)
3119 indx = 0;
3120 }
3121 else
3122 {
3123 i = 0;
3124 for (indx = len; indx > 0; indx--)
3125 {
3126 for (i = 0; i < lenc; i++)
3127 {
3128 if (c->value.character.string[i]
3129 == e->value.character.string[indx - 1])
3130 break;
3131 }
3132 if (i < lenc)
3133 break;
3134 }
3135 }
3136 }
3137 mpz_set_ui (result->value.integer, indx);
3138 return range_check (result, "SCAN");
3139 }
3140
3141
3142 gfc_expr *
3143 gfc_simplify_selected_int_kind (gfc_expr * e)
3144 {
3145 int i, kind, range;
3146 gfc_expr *result;
3147
3148 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
3149 return NULL;
3150
3151 kind = INT_MAX;
3152
3153 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3154 if (gfc_integer_kinds[i].range >= range
3155 && gfc_integer_kinds[i].kind < kind)
3156 kind = gfc_integer_kinds[i].kind;
3157
3158 if (kind == INT_MAX)
3159 kind = -1;
3160
3161 result = gfc_int_expr (kind);
3162 result->where = e->where;
3163
3164 return result;
3165 }
3166
3167
3168 gfc_expr *
3169 gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q)
3170 {
3171 int range, precision, i, kind, found_precision, found_range;
3172 gfc_expr *result;
3173
3174 if (p == NULL)
3175 precision = 0;
3176 else
3177 {
3178 if (p->expr_type != EXPR_CONSTANT
3179 || gfc_extract_int (p, &precision) != NULL)
3180 return NULL;
3181 }
3182
3183 if (q == NULL)
3184 range = 0;
3185 else
3186 {
3187 if (q->expr_type != EXPR_CONSTANT
3188 || gfc_extract_int (q, &range) != NULL)
3189 return NULL;
3190 }
3191
3192 kind = INT_MAX;
3193 found_precision = 0;
3194 found_range = 0;
3195
3196 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3197 {
3198 if (gfc_real_kinds[i].precision >= precision)
3199 found_precision = 1;
3200
3201 if (gfc_real_kinds[i].range >= range)
3202 found_range = 1;
3203
3204 if (gfc_real_kinds[i].precision >= precision
3205 && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind)
3206 kind = gfc_real_kinds[i].kind;
3207 }
3208
3209 if (kind == INT_MAX)
3210 {
3211 kind = 0;
3212
3213 if (!found_precision)
3214 kind = -1;
3215 if (!found_range)
3216 kind -= 2;
3217 }
3218
3219 result = gfc_int_expr (kind);
3220 result->where = (p != NULL) ? p->where : q->where;
3221
3222 return result;
3223 }
3224
3225
3226 gfc_expr *
3227 gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i)
3228 {
3229 gfc_expr *result;
3230 mpfr_t exp, absv, log2, pow2, frac;
3231 unsigned long exp2;
3232
3233 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
3234 return NULL;
3235
3236 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3237
3238 gfc_set_model_kind (x->ts.kind);
3239
3240 if (mpfr_sgn (x->value.real) == 0)
3241 {
3242 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
3243 return result;
3244 }
3245
3246 mpfr_init (absv);
3247 mpfr_init (log2);
3248 mpfr_init (exp);
3249 mpfr_init (pow2);
3250 mpfr_init (frac);
3251
3252 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3253 mpfr_log2 (log2, absv, GFC_RND_MODE);
3254
3255 mpfr_trunc (log2, log2);
3256 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
3257
3258 /* Old exponent value, and fraction. */
3259 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
3260
3261 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
3262
3263 /* New exponent. */
3264 exp2 = (unsigned long) mpz_get_d (i->value.integer);
3265 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
3266
3267 mpfr_clear (absv);
3268 mpfr_clear (log2);
3269 mpfr_clear (pow2);
3270 mpfr_clear (frac);
3271
3272 return range_check (result, "SET_EXPONENT");
3273 }
3274
3275
3276 gfc_expr *
3277 gfc_simplify_shape (gfc_expr * source)
3278 {
3279 mpz_t shape[GFC_MAX_DIMENSIONS];
3280 gfc_expr *result, *e, *f;
3281 gfc_array_ref *ar;
3282 int n;
3283 try t;
3284
3285 if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
3286 return NULL;
3287
3288 result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
3289 &source->where);
3290
3291 ar = gfc_find_array_ref (source);
3292
3293 t = gfc_array_ref_shape (ar, shape);
3294
3295 for (n = 0; n < source->rank; n++)
3296 {
3297 e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3298 &source->where);
3299
3300 if (t == SUCCESS)
3301 {
3302 mpz_set (e->value.integer, shape[n]);
3303 mpz_clear (shape[n]);
3304 }
3305 else
3306 {
3307 mpz_set_ui (e->value.integer, n + 1);
3308
3309 f = gfc_simplify_size (source, e);
3310 gfc_free_expr (e);
3311 if (f == NULL)
3312 {
3313 gfc_free_expr (result);
3314 return NULL;
3315 }
3316 else
3317 {
3318 e = f;
3319 }
3320 }
3321
3322 gfc_append_constructor (result, e);
3323 }
3324
3325 return result;
3326 }
3327
3328
3329 gfc_expr *
3330 gfc_simplify_size (gfc_expr * array, gfc_expr * dim)
3331 {
3332 mpz_t size;
3333 gfc_expr *result;
3334 int d;
3335
3336 if (dim == NULL)
3337 {
3338 if (gfc_array_size (array, &size) == FAILURE)
3339 return NULL;
3340 }
3341 else
3342 {
3343 if (dim->expr_type != EXPR_CONSTANT)
3344 return NULL;
3345
3346 d = mpz_get_ui (dim->value.integer) - 1;
3347 if (gfc_array_dimen_size (array, d, &size) == FAILURE)
3348 return NULL;
3349 }
3350
3351 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3352 &array->where);
3353
3354 mpz_set (result->value.integer, size);
3355
3356 return result;
3357 }
3358
3359
3360 gfc_expr *
3361 gfc_simplify_sign (gfc_expr * x, gfc_expr * y)
3362 {
3363 gfc_expr *result;
3364
3365 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3366 return NULL;
3367
3368 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3369
3370 switch (x->ts.type)
3371 {
3372 case BT_INTEGER:
3373 mpz_abs (result->value.integer, x->value.integer);
3374 if (mpz_sgn (y->value.integer) < 0)
3375 mpz_neg (result->value.integer, result->value.integer);
3376
3377 break;
3378
3379 case BT_REAL:
3380 /* TODO: Handle -0.0 and +0.0 correctly on machines that support
3381 it. */
3382 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
3383 if (mpfr_sgn (y->value.real) < 0)
3384 mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
3385
3386 break;
3387
3388 default:
3389 gfc_internal_error ("Bad type in gfc_simplify_sign");
3390 }
3391
3392 return result;
3393 }
3394
3395
3396 gfc_expr *
3397 gfc_simplify_sin (gfc_expr * x)
3398 {
3399 gfc_expr *result;
3400 mpfr_t xp, xq;
3401
3402 if (x->expr_type != EXPR_CONSTANT)
3403 return NULL;
3404
3405 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3406
3407 switch (x->ts.type)
3408 {
3409 case BT_REAL:
3410 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
3411 break;
3412
3413 case BT_COMPLEX:
3414 gfc_set_model (x->value.real);
3415 mpfr_init (xp);
3416 mpfr_init (xq);
3417
3418 mpfr_sin (xp, x->value.complex.r, GFC_RND_MODE);
3419 mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
3420 mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
3421
3422 mpfr_cos (xp, x->value.complex.r, GFC_RND_MODE);
3423 mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
3424 mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
3425
3426 mpfr_clear (xp);
3427 mpfr_clear (xq);
3428 break;
3429
3430 default:
3431 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
3432 }
3433
3434 return range_check (result, "SIN");
3435 }
3436
3437
3438 gfc_expr *
3439 gfc_simplify_sinh (gfc_expr * x)
3440 {
3441 gfc_expr *result;
3442
3443 if (x->expr_type != EXPR_CONSTANT)
3444 return NULL;
3445
3446 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3447
3448 mpfr_sinh(result->value.real, x->value.real, GFC_RND_MODE);
3449
3450 return range_check (result, "SINH");
3451 }
3452
3453
3454 /* The argument is always a double precision real that is converted to
3455 single precision. TODO: Rounding! */
3456
3457 gfc_expr *
3458 gfc_simplify_sngl (gfc_expr * a)
3459 {
3460 gfc_expr *result;
3461
3462 if (a->expr_type != EXPR_CONSTANT)
3463 return NULL;
3464
3465 result = gfc_real2real (a, gfc_default_real_kind);
3466 return range_check (result, "SNGL");
3467 }
3468
3469
3470 gfc_expr *
3471 gfc_simplify_spacing (gfc_expr * x)
3472 {
3473 gfc_expr *result;
3474 mpfr_t absv, log2;
3475 long diff;
3476 int i, p;
3477
3478 if (x->expr_type != EXPR_CONSTANT)
3479 return NULL;
3480
3481 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3482
3483 p = gfc_real_kinds[i].digits;
3484
3485 result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
3486
3487 gfc_set_model_kind (x->ts.kind);
3488
3489 if (mpfr_sgn (x->value.real) == 0)
3490 {
3491 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3492 return result;
3493 }
3494
3495 mpfr_init (log2);
3496 mpfr_init (absv);
3497
3498 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
3499 mpfr_log2 (log2, absv, GFC_RND_MODE);
3500 mpfr_trunc (log2, log2);
3501
3502 mpfr_add_ui (log2, log2, 1, GFC_RND_MODE);
3503
3504 /* FIXME: We should be using mpfr_get_si here, but this function is
3505 not available with the version of mpfr distributed with gmp (as of
3506 2004-09-17). Replace once mpfr has been imported into the gcc cvs
3507 tree. */
3508 diff = (long)mpfr_get_d (log2, GFC_RND_MODE) - (long)p;
3509 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
3510 mpfr_mul_2si (result->value.real, result->value.real, diff, GFC_RND_MODE);
3511
3512 mpfr_clear (log2);
3513 mpfr_clear (absv);
3514
3515 if (mpfr_cmp (result->value.real, gfc_real_kinds[i].tiny) < 0)
3516 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3517
3518 return range_check (result, "SPACING");
3519 }
3520
3521
3522 gfc_expr *
3523 gfc_simplify_sqrt (gfc_expr * e)
3524 {
3525 gfc_expr *result;
3526 mpfr_t ac, ad, s, t, w;
3527
3528 if (e->expr_type != EXPR_CONSTANT)
3529 return NULL;
3530
3531 result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
3532
3533 switch (e->ts.type)
3534 {
3535 case BT_REAL:
3536 if (mpfr_cmp_si (e->value.real, 0) < 0)
3537 goto negative_arg;
3538 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
3539
3540 break;
3541
3542 case BT_COMPLEX:
3543 /* Formula taken from Numerical Recipes to avoid over- and
3544 underflow. */
3545
3546 gfc_set_model (e->value.real);
3547 mpfr_init (ac);
3548 mpfr_init (ad);
3549 mpfr_init (s);
3550 mpfr_init (t);
3551 mpfr_init (w);
3552
3553 if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
3554 && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
3555 {
3556
3557 mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
3558 mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
3559 break;
3560 }
3561
3562 mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
3563 mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
3564
3565 if (mpfr_cmp (ac, ad) >= 0)
3566 {
3567 mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
3568 mpfr_mul (t, t, t, GFC_RND_MODE);
3569 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3570 mpfr_sqrt (t, t, GFC_RND_MODE);
3571 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3572 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3573 mpfr_sqrt (t, t, GFC_RND_MODE);
3574 mpfr_sqrt (s, ac, GFC_RND_MODE);
3575 mpfr_mul (w, s, t, GFC_RND_MODE);
3576 }
3577 else
3578 {
3579 mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
3580 mpfr_mul (t, s, s, GFC_RND_MODE);
3581 mpfr_add_ui (t, t, 1, GFC_RND_MODE);
3582 mpfr_sqrt (t, t, GFC_RND_MODE);
3583 mpfr_abs (s, s, GFC_RND_MODE);
3584 mpfr_add (t, t, s, GFC_RND_MODE);
3585 mpfr_div_ui (t, t, 2, GFC_RND_MODE);
3586 mpfr_sqrt (t, t, GFC_RND_MODE);
3587 mpfr_sqrt (s, ad, GFC_RND_MODE);
3588 mpfr_mul (w, s, t, GFC_RND_MODE);
3589 }
3590
3591 if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
3592 {
3593 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3594 mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
3595 mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
3596 }
3597 else if (mpfr_cmp_ui (w, 0) != 0
3598 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3599 && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
3600 {
3601 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3602 mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
3603 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3604 }
3605 else if (mpfr_cmp_ui (w, 0) != 0
3606 && mpfr_cmp_ui (e->value.complex.r, 0) < 0
3607 && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
3608 {
3609 mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
3610 mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
3611 mpfr_neg (w, w, GFC_RND_MODE);
3612 mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
3613 }
3614 else
3615 gfc_internal_error ("invalid complex argument of SQRT at %L",
3616 &e->where);
3617
3618 mpfr_clear (s);
3619 mpfr_clear (t);
3620 mpfr_clear (ac);
3621 mpfr_clear (ad);
3622 mpfr_clear (w);
3623
3624 break;
3625
3626 default:
3627 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
3628 }
3629
3630 return range_check (result, "SQRT");
3631
3632 negative_arg:
3633 gfc_free_expr (result);
3634 gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
3635 return &gfc_bad_expr;
3636 }
3637
3638
3639 gfc_expr *
3640 gfc_simplify_tan (gfc_expr * x)
3641 {
3642 int i;
3643 gfc_expr *result;
3644
3645 if (x->expr_type != EXPR_CONSTANT)
3646 return NULL;
3647
3648 i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
3649
3650 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3651
3652 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
3653
3654 return range_check (result, "TAN");
3655 }
3656
3657
3658 gfc_expr *
3659 gfc_simplify_tanh (gfc_expr * x)
3660 {
3661 gfc_expr *result;
3662
3663 if (x->expr_type != EXPR_CONSTANT)
3664 return NULL;
3665
3666 result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
3667
3668 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
3669
3670 return range_check (result, "TANH");
3671
3672 }
3673
3674
3675 gfc_expr *
3676 gfc_simplify_tiny (gfc_expr * e)
3677 {
3678 gfc_expr *result;
3679 int i;
3680
3681 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
3682
3683 result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
3684 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
3685
3686 return result;
3687 }
3688
3689
3690 gfc_expr *
3691 gfc_simplify_trim (gfc_expr * e)
3692 {
3693 gfc_expr *result;
3694 int count, i, len, lentrim;
3695
3696 if (e->expr_type != EXPR_CONSTANT)
3697 return NULL;
3698
3699 len = e->value.character.length;
3700
3701 result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
3702
3703 for (count = 0, i = 1; i <= len; ++i)
3704 {
3705 if (e->value.character.string[len - i] == ' ')
3706 count++;
3707 else
3708 break;
3709 }
3710
3711 lentrim = len - count;
3712
3713 result->value.character.length = lentrim;
3714 result->value.character.string = gfc_getmem (lentrim + 1);
3715
3716 for (i = 0; i < lentrim; i++)
3717 result->value.character.string[i] = e->value.character.string[i];
3718
3719 result->value.character.string[lentrim] = '\0'; /* For debugger */
3720
3721 return result;
3722 }
3723
3724
3725 gfc_expr *
3726 gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim)
3727 {
3728 return simplify_bound (array, dim, 1);
3729 }
3730
3731
3732 gfc_expr *
3733 gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
3734 {
3735 gfc_expr *result;
3736 int back;
3737 size_t index, len, lenset;
3738 size_t i;
3739
3740 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
3741 return NULL;
3742
3743 if (b != NULL && b->value.logical != 0)
3744 back = 1;
3745 else
3746 back = 0;
3747
3748 result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
3749 &s->where);
3750
3751 len = s->value.character.length;
3752 lenset = set->value.character.length;
3753
3754 if (len == 0)
3755 {
3756 mpz_set_ui (result->value.integer, 0);
3757 return result;
3758 }
3759
3760 if (back == 0)
3761 {
3762 if (lenset == 0)
3763 {
3764 mpz_set_ui (result->value.integer, len);
3765 return result;
3766 }
3767
3768 index =
3769 strspn (s->value.character.string, set->value.character.string) + 1;
3770 if (index > len)
3771 index = 0;
3772
3773 }
3774 else
3775 {
3776 if (lenset == 0)
3777 {
3778 mpz_set_ui (result->value.integer, 1);
3779 return result;
3780 }
3781 for (index = len; index > 0; index --)
3782 {
3783 for (i = 0; i < lenset; i++)
3784 {
3785 if (s->value.character.string[index - 1]
3786 == set->value.character.string[i])
3787 break;
3788 }
3789 if (i == lenset)
3790 break;
3791 }
3792 }
3793
3794 mpz_set_ui (result->value.integer, index);
3795 return result;
3796 }
3797
3798
3799 gfc_expr *
3800 gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
3801 {
3802 gfc_expr *result;
3803 int kind;
3804
3805 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3806 return NULL;
3807
3808 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
3809 if (x->ts.type == BT_INTEGER)
3810 {
3811 result = gfc_constant_result (BT_INTEGER, kind, &x->where);
3812 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
3813 }
3814 else /* BT_LOGICAL */
3815 {
3816 result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
3817 result->value.logical = (x->value.logical && ! y->value.logical)
3818 || (! x->value.logical && y->value.logical);
3819 }
3820
3821 return range_check (result, "XOR");
3822 }
3823
3824
3825
3826 /****************** Constant simplification *****************/
3827
3828 /* Master function to convert one constant to another. While this is
3829 used as a simplification function, it requires the destination type
3830 and kind information which is supplied by a special case in
3831 do_simplify(). */
3832
3833 gfc_expr *
3834 gfc_convert_constant (gfc_expr * e, bt type, int kind)
3835 {
3836 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
3837 gfc_constructor *head, *c, *tail = NULL;
3838
3839 switch (e->ts.type)
3840 {
3841 case BT_INTEGER:
3842 switch (type)
3843 {
3844 case BT_INTEGER:
3845 f = gfc_int2int;
3846 break;
3847 case BT_REAL:
3848 f = gfc_int2real;
3849 break;
3850 case BT_COMPLEX:
3851 f = gfc_int2complex;
3852 break;
3853 case BT_LOGICAL:
3854 f = gfc_int2log;
3855 break;
3856 default:
3857 goto oops;
3858 }
3859 break;
3860
3861 case BT_REAL:
3862 switch (type)
3863 {
3864 case BT_INTEGER:
3865 f = gfc_real2int;
3866 break;
3867 case BT_REAL:
3868 f = gfc_real2real;
3869 break;
3870 case BT_COMPLEX:
3871 f = gfc_real2complex;
3872 break;
3873 default:
3874 goto oops;
3875 }
3876 break;
3877
3878 case BT_COMPLEX:
3879 switch (type)
3880 {
3881 case BT_INTEGER:
3882 f = gfc_complex2int;
3883 break;
3884 case BT_REAL:
3885 f = gfc_complex2real;
3886 break;
3887 case BT_COMPLEX:
3888 f = gfc_complex2complex;
3889 break;
3890
3891 default:
3892 goto oops;
3893 }
3894 break;
3895
3896 case BT_LOGICAL:
3897 switch (type)
3898 {
3899 case BT_INTEGER:
3900 f = gfc_log2int;
3901 break;
3902 case BT_LOGICAL:
3903 f = gfc_log2log;
3904 break;
3905 default:
3906 goto oops;
3907 }
3908 break;
3909
3910 case BT_HOLLERITH:
3911 switch (type)
3912 {
3913 case BT_INTEGER:
3914 f = gfc_hollerith2int;
3915 break;
3916
3917 case BT_REAL:
3918 f = gfc_hollerith2real;
3919 break;
3920
3921 case BT_COMPLEX:
3922 f = gfc_hollerith2complex;
3923 break;
3924
3925 case BT_CHARACTER:
3926 f = gfc_hollerith2character;
3927 break;
3928
3929 case BT_LOGICAL:
3930 f = gfc_hollerith2logical;
3931 break;
3932
3933 default:
3934 goto oops;
3935 }
3936 break;
3937
3938 default:
3939 oops:
3940 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
3941 }
3942
3943 result = NULL;
3944
3945 switch (e->expr_type)
3946 {
3947 case EXPR_CONSTANT:
3948 result = f (e, kind);
3949 if (result == NULL)
3950 return &gfc_bad_expr;
3951 break;
3952
3953 case EXPR_ARRAY:
3954 if (!gfc_is_constant_expr (e))
3955 break;
3956
3957 head = NULL;
3958
3959 for (c = e->value.constructor; c; c = c->next)
3960 {
3961 if (head == NULL)
3962 head = tail = gfc_get_constructor ();
3963 else
3964 {
3965 tail->next = gfc_get_constructor ();
3966 tail = tail->next;
3967 }
3968
3969 tail->where = c->where;
3970
3971 if (c->iterator == NULL)
3972 tail->expr = f (c->expr, kind);
3973 else
3974 {
3975 g = gfc_convert_constant (c->expr, type, kind);
3976 if (g == &gfc_bad_expr)
3977 return g;
3978 tail->expr = g;
3979 }
3980
3981 if (tail->expr == NULL)
3982 {
3983 gfc_free_constructor (head);
3984 return NULL;
3985 }
3986 }
3987
3988 result = gfc_get_expr ();
3989 result->ts.type = type;
3990 result->ts.kind = kind;
3991 result->expr_type = EXPR_ARRAY;
3992 result->value.constructor = head;
3993 result->shape = gfc_copy_shape (e->shape, e->rank);
3994 result->where = e->where;
3995 result->rank = e->rank;
3996 break;
3997
3998 default:
3999 break;
4000 }
4001
4002 return result;
4003 }
4004
4005
4006 /****************** Helper functions ***********************/
4007
4008 /* Given a collating table, create the inverse table. */
4009
4010 static void
4011 invert_table (const int *table, int *xtable)
4012 {
4013 int i;
4014
4015 for (i = 0; i < 256; i++)
4016 xtable[i] = 0;
4017
4018 for (i = 0; i < 256; i++)
4019 xtable[table[i]] = i;
4020 }
4021
4022
4023 void
4024 gfc_simplify_init_1 (void)
4025 {
4026
4027 invert_table (ascii_table, xascii_table);
4028 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org