OSDN Git Service

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