OSDN Git Service

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