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