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