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