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