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