OSDN Git Service

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