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