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