OSDN Git Service

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