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