OSDN Git Service

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