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