OSDN Git Service

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