]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/simplify.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Replace enum gfc_try with bool type.
[thirdparty/gcc.git] / gcc / fortran / simplify.c
CommitLineData
6de9cd9a 1/* Simplify intrinsic functions at compile-time.
d1e082c2 2 Copyright (C) 2000-2013 Free Software Foundation, Inc.
6de9cd9a
DN		 3 Contributed by Andy Vaught & Katherine Holcomb
4
9fc4d79b 5This file is part of GCC.
6de9cd9a 6
9fc4d79b
TS		 7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
d234d788 9Software Foundation; either version 3, or (at your option) any later
9fc4d79b 10version.
6de9cd9a 11
9fc4d79b
TS		 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
6de9cd9a
DN		 16
17You should have received a copy of the GNU General Public License
d234d788
NC		 18along with GCC; see the file COPYING3. If not see
19<http://www.gnu.org/licenses/>. */
6de9cd9a
DN		 20
21#include "config.h"
22#include "system.h"
953bee7c 23#include "coretypes.h"
6de9cd9a 24#include "flags.h"
6de9cd9a
DN		 25#include "gfortran.h"
26#include "arith.h"
27#include "intrinsic.h"
7433458d 28#include "target-memory.h"
b7e75771 29#include "constructor.h"
1a8c1e35
TB		 30#include "tm.h" /* For BITS_PER_UNIT. */
31#include "version.h" /* For version_string. */
6de9cd9a 32
7ba8c18c 33
6de9cd9a
DN		 34gfc_expr gfc_bad_expr;
35
36
37/* Note that 'simplification' is not just transforming expressions.
38 For functions that are not simplified at compile time, range
39 checking is done if possible.
40
41 The return convention is that each simplification function returns:
42
43 A new expression node corresponding to the simplified arguments.
44 The original arguments are destroyed by the caller, and must not
45 be a part of the new expression.
46
47 NULL pointer indicating that no simplification was possible and
b7e75771 48 the original expression should remain intact.
6de9cd9a
DN		 49
50 An expression pointer to gfc_bad_expr (a static placeholder)
b7e75771
JD		 51 indicating that some error has prevented simplification. The
52 error is generated within the function and should be propagated
53 upwards
6de9cd9a
DN		 54
55 By the time a simplification function gets control, it has been
56 decided that the function call is really supposed to be the
57 intrinsic. No type checking is strictly necessary, since only
58 valid types will be passed on. On the other hand, a simplification
59 subroutine may have to look at the type of an argument as part of
60 its processing.
61
b7e75771
JD		 62 Array arguments are only passed to these subroutines that implement
63 the simplification of transformational intrinsics.
6de9cd9a
DN		 64
65 The functions in this file don't have much comment with them, but
66 everything is reasonably straight-forward. The Standard, chapter 13
67 is the best comment you'll find for this file anyway. */
68
6de9cd9a
DN		 69/* Range checks an expression node. If all goes well, returns the
70 node, otherwise returns &gfc_bad_expr and frees the node. */
71
72static gfc_expr *
edf1eac2 73range_check (gfc_expr *result, const char *name)
6de9cd9a 74{
e0f6835d
JD		 75 if (result == NULL)
76 return &gfc_bad_expr;
77
69dcd06a
DK		 78 if (result->expr_type != EXPR_CONSTANT)
79 return result;
80
54554825
JD		 81 switch (gfc_range_check (result))
82 {
83 case ARITH_OK:
84 return result;
8b704316 85
54554825 86 case ARITH_OVERFLOW:
edf1eac2
SK		 87 gfc_error ("Result of %s overflows its kind at %L", name,
88 &result->where);
54554825
JD		 89 break;
90
91 case ARITH_UNDERFLOW:
edf1eac2
SK		 92 gfc_error ("Result of %s underflows its kind at %L", name,
93 &result->where);
54554825
JD		 94 break;
95
96 case ARITH_NAN:
97 gfc_error ("Result of %s is NaN at %L", name, &result->where);
98 break;
99
100 default:
edf1eac2
SK		 101 gfc_error ("Result of %s gives range error for its kind at %L", name,
102 &result->where);
54554825
JD		 103 break;
104 }
105
6de9cd9a
DN		 106 gfc_free_expr (result);
107 return &gfc_bad_expr;
108}
109
110
111/* A helper function that gets an optional and possibly missing
112 kind parameter. Returns the kind, -1 if something went wrong. */
113
114static int
edf1eac2 115get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
6de9cd9a
DN		 116{
117 int kind;
118
119 if (k == NULL)
120 return default_kind;
121
122 if (k->expr_type != EXPR_CONSTANT)
123 {
124 gfc_error ("KIND parameter of %s at %L must be an initialization "
125 "expression", name, &k->where);
6de9cd9a
DN		 126 return -1;
127 }
128
129 if (gfc_extract_int (k, &kind) != NULL
e7a2d5fb 130 || gfc_validate_kind (type, kind, true) < 0)
6de9cd9a 131 {
6de9cd9a
DN		 132 gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
133 return -1;
134 }
135
136 return kind;
137}
138
139
f1dcb9bf
BM		 140/* Converts an mpz_t signed variable into an unsigned one, assuming
141 two's complement representations and a binary width of bitsize.
142 The conversion is a no-op unless x is negative; otherwise, it can
143 be accomplished by masking out the high bits. */
5d24a977
TS		 144
145static void
f1dcb9bf 146convert_mpz_to_unsigned (mpz_t x, int bitsize)
5d24a977
TS		 147{
148 mpz_t mask;
5d24a977 149
f1dcb9bf
BM		 150 if (mpz_sgn (x) < 0)
151 {
152 /* Confirm that no bits above the signed range are unset. */
153 gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
154
155 mpz_init_set_ui (mask, 1);
156 mpz_mul_2exp (mask, mask, bitsize);
157 mpz_sub_ui (mask, mask, 1);
158
159 mpz_and (x, x, mask);
160
161 mpz_clear (mask);
162 }
163 else
164 {
165 /* Confirm that no bits above the signed range are set. */
166 gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
167 }
168}
169
170
171/* Converts an mpz_t unsigned variable into a signed one, assuming
172 two's complement representations and a binary width of bitsize.
173 If the bitsize-1 bit is set, this is taken as a sign bit and
174 the number is converted to the corresponding negative number. */
175
f1dcb9bf
BM		 176static void
177convert_mpz_to_signed (mpz_t x, int bitsize)
178{
179 mpz_t mask;
180
181 /* Confirm that no bits above the unsigned range are set. */
182 gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
183
5d24a977
TS		 184 if (mpz_tstbit (x, bitsize - 1) == 1)
185 {
f1dcb9bf
BM		 186 mpz_init_set_ui (mask, 1);
187 mpz_mul_2exp (mask, mask, bitsize);
188 mpz_sub_ui (mask, mask, 1);
b7398e72
TS		 189
190 /* We negate the number by hand, zeroing the high bits, that is
edf1eac2
SK		 191 make it the corresponding positive number, and then have it
192 negated by GMP, giving the correct representation of the
193 negative number. */
5d24a977
TS		 194 mpz_com (x, x);
195 mpz_add_ui (x, x, 1);
196 mpz_and (x, x, mask);
197
198 mpz_neg (x, x);
199
200 mpz_clear (mask);
201 }
202}
203
b7e75771
JD		 204
205/* In-place convert BOZ to REAL of the specified kind. */
206
207static gfc_expr *
208convert_boz (gfc_expr *x, int kind)
209{
210 if (x && x->ts.type == BT_INTEGER && x->is_boz)
211 {
212 gfc_typespec ts;
213 gfc_clear_ts (&ts);
214 ts.type = BT_REAL;
215 ts.kind = kind;
216
217 if (!gfc_convert_boz (x, &ts))
218 return &gfc_bad_expr;
219 }
220
221 return x;
222}
223
224
7ba8c18c
DF		 225/* Test that the expression is an constant array. */
226
227static bool
228is_constant_array_expr (gfc_expr *e)
229{
230 gfc_constructor *c;
231
232 if (e == NULL)
233 return true;
234
235 if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
236 return false;
237
b7e75771
JD		 238 for (c = gfc_constructor_first (e->value.constructor);
239 c; c = gfc_constructor_next (c))
15c2ef5a
PT		 240 if (c->expr->expr_type != EXPR_CONSTANT
241 && c->expr->expr_type != EXPR_STRUCTURE)
7ba8c18c
DF		 242 return false;
243
244 return true;
245}
246
247
8ec259c1
DF		 248/* Initialize a transformational result expression with a given value. */
249
250static void
251init_result_expr (gfc_expr *e, int init, gfc_expr *array)
252{
253 if (e && e->expr_type == EXPR_ARRAY)
254 {
b7e75771 255 gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
8ec259c1
DF		 256 while (ctor)
257 {
258 init_result_expr (ctor->expr, init, array);
b7e75771 259 ctor = gfc_constructor_next (ctor);
8ec259c1
DF		 260 }
261 }
262 else if (e && e->expr_type == EXPR_CONSTANT)
263 {
264 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
265 int length;
266 gfc_char_t *string;
267
268 switch (e->ts.type)
269 {
270 case BT_LOGICAL:
271 e->value.logical = (init ? 1 : 0);
272 break;
273
274 case BT_INTEGER:
275 if (init == INT_MIN)
276 mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
277 else if (init == INT_MAX)
278 mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
279 else
280 mpz_set_si (e->value.integer, init);
281 break;
282
283 case BT_REAL:
284 if (init == INT_MIN)
285 {
286 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
287 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
288 }
289 else if (init == INT_MAX)
290 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
291 else
292 mpfr_set_si (e->value.real, init, GFC_RND_MODE);
293 break;
294
295 case BT_COMPLEX:
eb6f9a86 296 mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
8ec259c1
DF		 297 break;
298
299 case BT_CHARACTER:
300 if (init == INT_MIN)
301 {
302 gfc_expr *len = gfc_simplify_len (array, NULL);
303 gfc_extract_int (len, &length);
304 string = gfc_get_wide_string (length + 1);
305 gfc_wide_memset (string, 0, length);
306 }
307 else if (init == INT_MAX)
308 {
309 gfc_expr *len = gfc_simplify_len (array, NULL);
310 gfc_extract_int (len, &length);
311 string = gfc_get_wide_string (length + 1);
312 gfc_wide_memset (string, 255, length);
313 }
314 else
315 {
316 length = 0;
317 string = gfc_get_wide_string (1);
318 }
319
320 string[length] = '\0';
321 e->value.character.length = length;
322 e->value.character.string = string;
323 break;
324
325 default:
326 gcc_unreachable();
327 }
328 }
329 else
330 gcc_unreachable();
331}
332
333
334/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */
335
336static gfc_expr *
b7e75771
JD		 337compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
338 gfc_expr *matrix_b, int stride_b, int offset_b)
8ec259c1 339{
b7e75771 340 gfc_expr *result, *a, *b;
8ec259c1 341
b7e75771
JD		 342 result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind,
343 &matrix_a->where);
8ec259c1
DF		 344 init_result_expr (result, 0, NULL);
345
b7e75771
JD		 346 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
347 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
348 while (a && b)
8ec259c1
DF		 349 {
350 /* Copying of expressions is required as operands are free'd
351 by the gfc_arith routines. */
352 switch (result->ts.type)
353 {
354 case BT_LOGICAL:
355 result = gfc_or (result,
b7e75771
JD		 356 gfc_and (gfc_copy_expr (a),
357 gfc_copy_expr (b)));
8ec259c1
DF		 358 break;
359
360 case BT_INTEGER:
361 case BT_REAL:
362 case BT_COMPLEX:
363 result = gfc_add (result,
b7e75771
JD		 364 gfc_multiply (gfc_copy_expr (a),
365 gfc_copy_expr (b)));
8ec259c1
DF		 366 break;
367
368 default:
369 gcc_unreachable();
370 }
371
b7e75771
JD		 372 offset_a += stride_a;
373 a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
374
375 offset_b += stride_b;
376 b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
8ec259c1
DF		 377 }
378
379 return result;
380}
381
a16d978f 382
8b704316 383/* Build a result expression for transformational intrinsics,
a16d978f
DF		 384 depending on DIM. */
385
386static gfc_expr *
387transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
388 int kind, locus* where)
389{
390 gfc_expr *result;
391 int i, nelem;
392
393 if (!dim || array->rank == 1)
b7e75771 394 return gfc_get_constant_expr (type, kind, where);
a16d978f 395
b7e75771 396 result = gfc_get_array_expr (type, kind, where);
a16d978f
DF		 397 result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
398 result->rank = array->rank - 1;
399
400 /* gfc_array_size() would count the number of elements in the constructor,
401 we have not built those yet. */
402 nelem = 1;
403 for (i = 0; i < result->rank; ++i)
404 nelem *= mpz_get_ui (result->shape[i]);
405
406 for (i = 0; i < nelem; ++i)
407 {
b7e75771
JD		 408 gfc_constructor_append_expr (&result->value.constructor,
409 gfc_get_constant_expr (type, kind, where),
410 NULL);
a16d978f
DF		 411 }
412
413 return result;
414}
415
416
417typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
418
419/* Wrapper function, implements 'op1 += 1'. Only called if MASK
420 of COUNT intrinsic is .TRUE..
421
62732c30 422 Interface and implementation mimics arith functions as
a16d978f
DF		 423 gfc_add, gfc_multiply, etc. */
424
425static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2)
426{
427 gfc_expr *result;
428
429 gcc_assert (op1->ts.type == BT_INTEGER);
430 gcc_assert (op2->ts.type == BT_LOGICAL);
431 gcc_assert (op2->value.logical);
432
433 result = gfc_copy_expr (op1);
434 mpz_add_ui (result->value.integer, result->value.integer, 1);
435
436 gfc_free_expr (op1);
437 gfc_free_expr (op2);
438 return result;
439}
440
441
442/* Transforms an ARRAY with operation OP, according to MASK, to a
443 scalar RESULT. E.g. called if
444
445 REAL, PARAMETER :: array(n, m) = ...
446 REAL, PARAMETER :: s = SUM(array)
447
448 where OP == gfc_add(). */
449
450static gfc_expr *
451simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
452 transformational_op op)
453{
454 gfc_expr *a, *m;
455 gfc_constructor *array_ctor, *mask_ctor;
456
457 /* Shortcut for constant .FALSE. MASK. */
458 if (mask
459 && mask->expr_type == EXPR_CONSTANT
460 && !mask->value.logical)
461 return result;
462
b7e75771 463 array_ctor = gfc_constructor_first (array->value.constructor);
a16d978f
DF		 464 mask_ctor = NULL;
465 if (mask && mask->expr_type == EXPR_ARRAY)
b7e75771 466 mask_ctor = gfc_constructor_first (mask->value.constructor);
a16d978f
DF		 467
468 while (array_ctor)
469 {
470 a = array_ctor->expr;
b7e75771 471 array_ctor = gfc_constructor_next (array_ctor);
a16d978f
DF		 472
473 /* A constant MASK equals .TRUE. here and can be ignored. */
474 if (mask_ctor)
475 {
476 m = mask_ctor->expr;
b7e75771 477 mask_ctor = gfc_constructor_next (mask_ctor);
a16d978f
DF		 478 if (!m->value.logical)
479 continue;
480 }
481
482 result = op (result, gfc_copy_expr (a));
483 }
484
485 return result;
486}
487
488/* Transforms an ARRAY with operation OP, according to MASK, to an
489 array RESULT. E.g. called if
490
491 REAL, PARAMETER :: array(n, m) = ...
492 REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
493
8b704316 494 where OP == gfc_multiply(). The result might be post processed using post_op. */
a16d978f
DF		 495
496static gfc_expr *
497simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
0cd0559e
TB		 498 gfc_expr *mask, transformational_op op,
499 transformational_op post_op)
a16d978f
DF		 500{
501 mpz_t size;
502 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
503 gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
504 gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
505
506 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
507 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
508 tmpstride[GFC_MAX_DIMENSIONS];
509
510 /* Shortcut for constant .FALSE. MASK. */
511 if (mask
512 && mask->expr_type == EXPR_CONSTANT
513 && !mask->value.logical)
514 return result;
515
516 /* Build an indexed table for array element expressions to minimize
517 linked-list traversal. Masked elements are set to NULL. */
518 gfc_array_size (array, &size);
519 arraysize = mpz_get_ui (size);
9c85d38b 520 mpz_clear (size);
a16d978f 521
93acb62c 522 arrayvec = XCNEWVEC (gfc_expr*, arraysize);
a16d978f 523
b7e75771 524 array_ctor = gfc_constructor_first (array->value.constructor);
a16d978f
DF		 525 mask_ctor = NULL;
526 if (mask && mask->expr_type == EXPR_ARRAY)
b7e75771 527 mask_ctor = gfc_constructor_first (mask->value.constructor);
a16d978f
DF		 528
529 for (i = 0; i < arraysize; ++i)
530 {
531 arrayvec[i] = array_ctor->expr;
b7e75771 532 array_ctor = gfc_constructor_next (array_ctor);
a16d978f
DF		 533
534 if (mask_ctor)
535 {
536 if (!mask_ctor->expr->value.logical)
537 arrayvec[i] = NULL;
538
b7e75771 539 mask_ctor = gfc_constructor_next (mask_ctor);
a16d978f
DF		 540 }
541 }
542
543 /* Same for the result expression. */
544 gfc_array_size (result, &size);
545 resultsize = mpz_get_ui (size);
546 mpz_clear (size);
547
93acb62c 548 resultvec = XCNEWVEC (gfc_expr*, resultsize);
b7e75771 549 result_ctor = gfc_constructor_first (result->value.constructor);
a16d978f
DF		 550 for (i = 0; i < resultsize; ++i)
551 {
552 resultvec[i] = result_ctor->expr;
b7e75771 553 result_ctor = gfc_constructor_next (result_ctor);
a16d978f
DF		 554 }
555
556 gfc_extract_int (dim, &dim_index);
557 dim_index -= 1; /* zero-base index */
558 dim_extent = 0;
559 dim_stride = 0;
560
561 for (i = 0, n = 0; i < array->rank; ++i)
562 {
563 count[i] = 0;
564 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
565 if (i == dim_index)
566 {
567 dim_extent = mpz_get_si (array->shape[i]);
568 dim_stride = tmpstride[i];
569 continue;
570 }
571
572 extent[n] = mpz_get_si (array->shape[i]);
573 sstride[n] = tmpstride[i];
574 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
575 n += 1;
576 }
577
578 done = false;
579 base = arrayvec;
580 dest = resultvec;
581 while (!done)
582 {
583 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
584 if (*src)
585 *dest = op (*dest, gfc_copy_expr (*src));
586
587 count[0]++;
588 base += sstride[0];
589 dest += dstride[0];
590
591 n = 0;
592 while (!done && count[n] == extent[n])
593 {
594 count[n] = 0;
595 base -= sstride[n] * extent[n];
596 dest -= dstride[n] * extent[n];
597
598 n++;
599 if (n < result->rank)
600 {
601 count [n]++;
602 base += sstride[n];
603 dest += dstride[n];
604 }
605 else
606 done = true;
607 }
608 }
609
610 /* Place updated expression in result constructor. */
b7e75771 611 result_ctor = gfc_constructor_first (result->value.constructor);
a16d978f
DF		 612 for (i = 0; i < resultsize; ++i)
613 {
0cd0559e
TB		 614 if (post_op)
615 result_ctor->expr = post_op (result_ctor->expr, resultvec[i]);
616 else
617 result_ctor->expr = resultvec[i];
b7e75771 618 result_ctor = gfc_constructor_next (result_ctor);
a16d978f
DF		 619 }
620
cede9502
JM		 621 free (arrayvec);
622 free (resultvec);
a16d978f
DF		 623 return result;
624}
625
626
195a95c4
TB		 627static gfc_expr *
628simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
629 int init_val, transformational_op op)
630{
631 gfc_expr *result;
632
633 if (!is_constant_array_expr (array)
634 || !gfc_is_constant_expr (dim))
635 return NULL;
636
637 if (mask
638 && !is_constant_array_expr (mask)
639 && mask->expr_type != EXPR_CONSTANT)
640 return NULL;
641
642 result = transformational_result (array, dim, array->ts.type,
643 array->ts.kind, &array->where);
644 init_result_expr (result, init_val, NULL);
645
646 return !dim || array->rank == 1 ?
647 simplify_transformation_to_scalar (result, array, mask, op) :
648 simplify_transformation_to_array (result, array, dim, mask, op, NULL);
649}
650
a16d978f 651
6de9cd9a
DN		 652/********************** Simplification functions *****************************/
653
654gfc_expr *
edf1eac2 655gfc_simplify_abs (gfc_expr *e)
6de9cd9a
DN		 656{
657 gfc_expr *result;
6de9cd9a
DN		 658
659 if (e->expr_type != EXPR_CONSTANT)
660 return NULL;
661
662 switch (e->ts.type)
663 {
b7e75771
JD		 664 case BT_INTEGER:
665 result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
666 mpz_abs (result->value.integer, e->value.integer);
667 return range_check (result, "IABS");
6de9cd9a 668
b7e75771
JD		 669 case BT_REAL:
670 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
671 mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
672 return range_check (result, "ABS");
6de9cd9a 673
b7e75771
JD		 674 case BT_COMPLEX:
675 gfc_set_model_kind (e->ts.kind);
676 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
677 mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
678 return range_check (result, "CABS");
6de9cd9a 679
b7e75771
JD		 680 default:
681 gfc_internal_error ("gfc_simplify_abs(): Bad type");
6de9cd9a 682 }
6de9cd9a
DN		 683}
684
685
d393bbd7
FXC		 686static gfc_expr *
687simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
6de9cd9a
DN		 688{
689 gfc_expr *result;
d393bbd7
FXC		 690 int kind;
691 bool too_large = false;
6de9cd9a
DN		 692
693 if (e->expr_type != EXPR_CONSTANT)
694 return NULL;
695
d393bbd7 696 kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
719e72fb
FXC		 697 if (kind == -1)
698 return &gfc_bad_expr;
699
d393bbd7
FXC		 700 if (mpz_cmp_si (e->value.integer, 0) < 0)
701 {
702 gfc_error ("Argument of %s function at %L is negative", name,
703 &e->where);
704 return &gfc_bad_expr;
705 }
34462c28 706
d393bbd7
FXC		 707 if (ascii && gfc_option.warn_surprising
708 && mpz_cmp_si (e->value.integer, 127) > 0)
709 gfc_warning ("Argument of %s function at %L outside of range [0,127]",
710 name, &e->where);
34462c28 711
d393bbd7
FXC		 712 if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
713 too_large = true;
714 else if (kind == 4)
715 {
716 mpz_t t;
717 mpz_init_set_ui (t, 2);
718 mpz_pow_ui (t, t, 32);
719 mpz_sub_ui (t, t, 1);
720 if (mpz_cmp (e->value.integer, t) > 0)
721 too_large = true;
722 mpz_clear (t);
723 }
6de9cd9a 724
d393bbd7
FXC		 725 if (too_large)
726 {
727 gfc_error ("Argument of %s function at %L is too large for the "
728 "collating sequence of kind %d", name, &e->where, kind);
729 return &gfc_bad_expr;
730 }
6de9cd9a 731
b7e75771 732 result = gfc_get_character_expr (kind, &e->where, NULL, 1);
d393bbd7 733 result->value.character.string[0] = mpz_get_ui (e->value.integer);
b7e75771 734
6de9cd9a
DN		 735 return result;
736}
737
738
d393bbd7
FXC		 739
740/* We use the processor's collating sequence, because all
741 systems that gfortran currently works on are ASCII. */
742
743gfc_expr *
744gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
745{
746 return simplify_achar_char (e, k, "ACHAR", true);
747}
748
749
6de9cd9a 750gfc_expr *
edf1eac2 751gfc_simplify_acos (gfc_expr *x)
6de9cd9a
DN		 752{
753 gfc_expr *result;
6de9cd9a
DN		 754
755 if (x->expr_type != EXPR_CONSTANT)
756 return NULL;
757
504ed63a 758 switch (x->ts.type)
6de9cd9a 759 {
504ed63a
TB		 760 case BT_REAL:
761 if (mpfr_cmp_si (x->value.real, 1) > 0
762 || mpfr_cmp_si (x->value.real, -1) < 0)
763 {
764 gfc_error ("Argument of ACOS at %L must be between -1 and 1",
765 &x->where);
766 return &gfc_bad_expr;
767 }
b7e75771 768 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8e70c271 769 mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
504ed63a 770 break;
b7e75771 771
504ed63a 772 case BT_COMPLEX:
b7e75771 773 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8e70c271
KG		 774 mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
775 break;
b7e75771 776
504ed63a 777 default:
67749498 778 gfc_internal_error ("in gfc_simplify_acos(): Bad type");
6de9cd9a
DN		 779 }
780
6de9cd9a
DN		 781 return range_check (result, "ACOS");
782}
783
1e399e23 784gfc_expr *
edf1eac2 785gfc_simplify_acosh (gfc_expr *x)
1e399e23
JD		 786{
787 gfc_expr *result;
788
789 if (x->expr_type != EXPR_CONSTANT)
790 return NULL;
791
504ed63a 792 switch (x->ts.type)
1e399e23 793 {
504ed63a
TB		 794 case BT_REAL:
795 if (mpfr_cmp_si (x->value.real, 1) < 0)
796 {
797 gfc_error ("Argument of ACOSH at %L must not be less than 1",
798 &x->where);
799 return &gfc_bad_expr;
800 }
1e399e23 801
b7e75771 802 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
504ed63a
TB		 803 mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
804 break;
b7e75771 805
504ed63a 806 case BT_COMPLEX:
b7e75771 807 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8e70c271
KG		 808 mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
809 break;
b7e75771 810
504ed63a 811 default:
67749498 812 gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
504ed63a 813 }
1e399e23
JD		 814
815 return range_check (result, "ACOSH");
816}
6de9cd9a
DN		 817
818gfc_expr *
edf1eac2 819gfc_simplify_adjustl (gfc_expr *e)
6de9cd9a
DN		 820{
821 gfc_expr *result;
822 int count, i, len;
00660189 823 gfc_char_t ch;
6de9cd9a
DN		 824
825 if (e->expr_type != EXPR_CONSTANT)
826 return NULL;
827
828 len = e->value.character.length;
829
6de9cd9a
DN		 830 for (count = 0, i = 0; i < len; ++i)
831 {
832 ch = e->value.character.string[i];
833 if (ch != ' ')
834 break;
835 ++count;
836 }
837
b7e75771 838 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
6de9cd9a 839 for (i = 0; i < len - count; ++i)
edf1eac2 840 result->value.character.string[i] = e->value.character.string[count + i];
6de9cd9a 841
6de9cd9a
DN		 842 return result;
843}
844
845
846gfc_expr *
edf1eac2 847gfc_simplify_adjustr (gfc_expr *e)
6de9cd9a
DN		 848{
849 gfc_expr *result;
850 int count, i, len;
00660189 851 gfc_char_t ch;
6de9cd9a
DN		 852
853 if (e->expr_type != EXPR_CONSTANT)
854 return NULL;
855
856 len = e->value.character.length;
857
6de9cd9a
DN		 858 for (count = 0, i = len - 1; i >= 0; --i)
859 {
860 ch = e->value.character.string[i];
861 if (ch != ' ')
862 break;
863 ++count;
864 }
865
b7e75771 866 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
6de9cd9a 867 for (i = 0; i < count; ++i)
edf1eac2 868 result->value.character.string[i] = ' ';
6de9cd9a
DN		 869
870 for (i = count; i < len; ++i)
edf1eac2 871 result->value.character.string[i] = e->value.character.string[i - count];
6de9cd9a 872
6de9cd9a
DN		 873 return result;
874}
875
876
877gfc_expr *
edf1eac2 878gfc_simplify_aimag (gfc_expr *e)
6de9cd9a
DN		 879{
880 gfc_expr *result;
881
882 if (e->expr_type != EXPR_CONSTANT)
883 return NULL;
884
b7e75771 885 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
eb6f9a86 886 mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
6de9cd9a
DN		 887
888 return range_check (result, "AIMAG");
889}
890
891
892gfc_expr *
edf1eac2 893gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
6de9cd9a
DN		 894{
895 gfc_expr *rtrunc, *result;
896 int kind;
897
898 kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
899 if (kind == -1)
900 return &gfc_bad_expr;
901
902 if (e->expr_type != EXPR_CONSTANT)
903 return NULL;
904
905 rtrunc = gfc_copy_expr (e);
f8e566e5 906 mpfr_trunc (rtrunc->value.real, e->value.real);
6de9cd9a
DN		 907
908 result = gfc_real2real (rtrunc, kind);
b7e75771 909
6de9cd9a
DN		 910 gfc_free_expr (rtrunc);
911
912 return range_check (result, "AINT");
913}
914
915
a16d978f
DF		 916gfc_expr *
917gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
918{
195a95c4 919 return simplify_transformation (mask, dim, NULL, true, gfc_and);
a16d978f
DF		 920}
921
922
6de9cd9a 923gfc_expr *
edf1eac2 924gfc_simplify_dint (gfc_expr *e)
6de9cd9a
DN		 925{
926 gfc_expr *rtrunc, *result;
927
928 if (e->expr_type != EXPR_CONSTANT)
929 return NULL;
930
931 rtrunc = gfc_copy_expr (e);
f8e566e5 932 mpfr_trunc (rtrunc->value.real, e->value.real);
6de9cd9a 933
9d64df18 934 result = gfc_real2real (rtrunc, gfc_default_double_kind);
b7e75771 935
6de9cd9a
DN		 936 gfc_free_expr (rtrunc);
937
938 return range_check (result, "DINT");
6de9cd9a
DN		 939}
940
941
02c74373
FXC		 942gfc_expr *
943gfc_simplify_dreal (gfc_expr *e)
944{
945 gfc_expr *result = NULL;
946
947 if (e->expr_type != EXPR_CONSTANT)
948 return NULL;
949
950 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
951 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
952
953 return range_check (result, "DREAL");
954}
955
956
6de9cd9a 957gfc_expr *
edf1eac2 958gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
6de9cd9a 959{
8e1fa5d6
SK		 960 gfc_expr *result;
961 int kind;
6de9cd9a
DN		 962
963 kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
964 if (kind == -1)
965 return &gfc_bad_expr;
966
967 if (e->expr_type != EXPR_CONSTANT)
968 return NULL;
969
b7e75771 970 result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
8e1fa5d6 971 mpfr_round (result->value.real, e->value.real);
6de9cd9a
DN		 972
973 return range_check (result, "ANINT");
974}
975
976
5d723e54 977gfc_expr *
edf1eac2 978gfc_simplify_and (gfc_expr *x, gfc_expr *y)
5d723e54
FXC		 979{
980 gfc_expr *result;
981 int kind;
982
983 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
984 return NULL;
985
986 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
b7e75771
JD		 987
988 switch (x->ts.type)
5d723e54 989 {
b7e75771
JD		 990 case BT_INTEGER:
991 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
992 mpz_and (result->value.integer, x->value.integer, y->value.integer);
993 return range_check (result, "AND");
994
995 case BT_LOGICAL:
996 return gfc_get_logical_expr (kind, &x->where,
997 x->value.logical && y->value.logical);
998
999 default:
1000 gcc_unreachable ();
5d723e54 1001 }
5d723e54
FXC		 1002}
1003
1004
a16d978f
DF		 1005gfc_expr *
1006gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
1007{
195a95c4 1008 return simplify_transformation (mask, dim, NULL, false, gfc_or);
a16d978f
DF		 1009}
1010
1011
6de9cd9a 1012gfc_expr *
edf1eac2 1013gfc_simplify_dnint (gfc_expr *e)
6de9cd9a 1014{
8e1fa5d6 1015 gfc_expr *result;
6de9cd9a
DN		 1016
1017 if (e->expr_type != EXPR_CONSTANT)
1018 return NULL;
1019
b7e75771 1020 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
8e1fa5d6 1021 mpfr_round (result->value.real, e->value.real);
6de9cd9a
DN		 1022
1023 return range_check (result, "DNINT");
1024}
1025
1026
1027gfc_expr *
edf1eac2 1028gfc_simplify_asin (gfc_expr *x)
6de9cd9a
DN		 1029{
1030 gfc_expr *result;
6de9cd9a
DN		 1031
1032 if (x->expr_type != EXPR_CONSTANT)
1033 return NULL;
1034
504ed63a 1035 switch (x->ts.type)
6de9cd9a 1036 {
504ed63a
TB		 1037 case BT_REAL:
1038 if (mpfr_cmp_si (x->value.real, 1) > 0
1039 || mpfr_cmp_si (x->value.real, -1) < 0)
1040 {
1041 gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1042 &x->where);
1043 return &gfc_bad_expr;
1044 }
b7e75771 1045 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
504ed63a
TB		 1046 mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1047 break;
b7e75771 1048
504ed63a 1049 case BT_COMPLEX:
b7e75771 1050 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8e70c271
KG		 1051 mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1052 break;
b7e75771 1053
504ed63a 1054 default:
67749498 1055 gfc_internal_error ("in gfc_simplify_asin(): Bad type");
6de9cd9a
DN		 1056 }
1057
6de9cd9a
DN		 1058 return range_check (result, "ASIN");
1059}
1060
1061
1062gfc_expr *
edf1eac2 1063gfc_simplify_asinh (gfc_expr *x)
6de9cd9a
DN		 1064{
1065 gfc_expr *result;
1066
1067 if (x->expr_type != EXPR_CONSTANT)
1068 return NULL;
1069
b7e75771
JD		 1070 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1071
504ed63a
TB		 1072 switch (x->ts.type)
1073 {
1074 case BT_REAL:
504ed63a
TB		 1075 mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
1076 break;
b7e75771 1077
504ed63a 1078 case BT_COMPLEX:
8e70c271
KG		 1079 mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1080 break;
b7e75771 1081
504ed63a 1082 default:
67749498 1083 gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
504ed63a 1084 }
1e399e23
JD		 1085
1086 return range_check (result, "ASINH");
1087}
1088
1089
1090gfc_expr *
edf1eac2 1091gfc_simplify_atan (gfc_expr *x)
1e399e23
JD		 1092{
1093 gfc_expr *result;
1094
1095 if (x->expr_type != EXPR_CONSTANT)
1096 return NULL;
b7e75771
JD		 1097
1098 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1099
504ed63a
TB		 1100 switch (x->ts.type)
1101 {
1102 case BT_REAL:
504ed63a
TB		 1103 mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1104 break;
b7e75771 1105
504ed63a 1106 case BT_COMPLEX:
8e70c271
KG		 1107 mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1108 break;
b7e75771 1109
504ed63a 1110 default:
67749498 1111 gfc_internal_error ("in gfc_simplify_atan(): Bad type");
504ed63a 1112 }
6de9cd9a
DN		 1113
1114 return range_check (result, "ATAN");
1e399e23
JD		 1115}
1116
1117
1118gfc_expr *
edf1eac2 1119gfc_simplify_atanh (gfc_expr *x)
1e399e23
JD		 1120{
1121 gfc_expr *result;
6de9cd9a 1122
1e399e23
JD		 1123 if (x->expr_type != EXPR_CONSTANT)
1124 return NULL;
1125
504ed63a 1126 switch (x->ts.type)
1e399e23 1127 {
504ed63a
TB		 1128 case BT_REAL:
1129 if (mpfr_cmp_si (x->value.real, 1) >= 0
1130 || mpfr_cmp_si (x->value.real, -1) <= 0)
1131 {
1132 gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1133 "to 1", &x->where);
1134 return &gfc_bad_expr;
1135 }
b7e75771 1136 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
504ed63a
TB		 1137 mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
1138 break;
b7e75771 1139
504ed63a 1140 case BT_COMPLEX:
b7e75771 1141 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8e70c271
KG		 1142 mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1143 break;
b7e75771 1144
504ed63a 1145 default:
67749498 1146 gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
504ed63a 1147 }
1e399e23
JD		 1148
1149 return range_check (result, "ATANH");
6de9cd9a
DN		 1150}
1151
1152
1153gfc_expr *
edf1eac2 1154gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
6de9cd9a
DN		 1155{
1156 gfc_expr *result;
1157
1158 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1159 return NULL;
1160
f8e566e5 1161 if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
6de9cd9a 1162 {
edf1eac2
SK		 1163 gfc_error ("If first argument of ATAN2 %L is zero, then the "
1164 "second argument must not be zero", &x->where);
6de9cd9a
DN		 1165 return &gfc_bad_expr;
1166 }
1167
b7e75771 1168 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
e48d66a9 1169 mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
6de9cd9a
DN		 1170
1171 return range_check (result, "ATAN2");
6de9cd9a
DN		 1172}
1173
1174
3c3f4265 1175gfc_expr *
b7e75771 1176gfc_simplify_bessel_j0 (gfc_expr *x)
3c3f4265 1177{
3c3f4265
TB		 1178 gfc_expr *result;
1179
1180 if (x->expr_type != EXPR_CONSTANT)
1181 return NULL;
1182
b7e75771 1183 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3c3f4265
TB		 1184 mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
1185
1186 return range_check (result, "BESSEL_J0");
3c3f4265
TB		 1187}
1188
1189
1190gfc_expr *
b7e75771 1191gfc_simplify_bessel_j1 (gfc_expr *x)
3c3f4265 1192{
3c3f4265
TB		 1193 gfc_expr *result;
1194
1195 if (x->expr_type != EXPR_CONSTANT)
1196 return NULL;
1197
b7e75771 1198 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3c3f4265
TB		 1199 mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
1200
1201 return range_check (result, "BESSEL_J1");
3c3f4265
TB		 1202}
1203
1204
1205gfc_expr *
b7e75771 1206gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
3c3f4265 1207{
3c3f4265
TB		 1208 gfc_expr *result;
1209 long n;
1210
1211 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1212 return NULL;
1213
1214 n = mpz_get_si (order->value.integer);
b7e75771 1215 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3c3f4265
TB		 1216 mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
1217
1218 return range_check (result, "BESSEL_JN");
3c3f4265
TB		 1219}
1220
1221
29698e0f
TB		 1222/* Simplify transformational form of JN and YN. */
1223
1224static gfc_expr *
1225gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
1226 bool jn)
1227{
1228 gfc_expr *result;
1229 gfc_expr *e;
1230 long n1, n2;
1231 int i;
1232 mpfr_t x2rev, last1, last2;
1233
1234 if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT
1235 || order2->expr_type != EXPR_CONSTANT)
47b99694 1236 return NULL;
29698e0f
TB		 1237
1238 n1 = mpz_get_si (order1->value.integer);
1239 n2 = mpz_get_si (order2->value.integer);
1240 result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where);
1241 result->rank = 1;
1242 result->shape = gfc_get_shape (1);
1243 mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0));
1244
1245 if (n2 < n1)
1246 return result;
1247
1248 /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1249 YN(N, 0.0) = -Inf. */
1250
1251 if (mpfr_cmp_ui (x->value.real, 0.0) == 0)
1252 {
1253 if (!jn && gfc_option.flag_range_check)
1254 {
1255 gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where);
1256 gfc_free_expr (result);
1257 return &gfc_bad_expr;
1258 }
1259
1260 if (jn && n1 == 0)
1261 {
1262 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4c6e913c 1263 mpfr_set_ui (e->value.real, 1, GFC_RND_MODE);
29698e0f
TB		 1264 gfc_constructor_append_expr (&result->value.constructor, e,
1265 &x->where);
1266 n1++;
1267 }
1268
1269 for (i = n1; i <= n2; i++)
1270 {
1271 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1272 if (jn)
4c6e913c 1273 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
29698e0f 1274 else
47b99694 1275 mpfr_set_inf (e->value.real, -1);
29698e0f
TB		 1276 gfc_constructor_append_expr (&result->value.constructor, e,
1277 &x->where);
1278 }
1279
1280 return result;
1281 }
1282
d76799c7 1283 /* Use the faster but more verbose recurrence algorithm. Bessel functions
29698e0f
TB		 1284 are stable for downward recursion and Neumann functions are stable
1285 for upward recursion. It is
1286 x2rev = 2.0/x,
1287 J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1288 Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1289 Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1290
1291 gfc_set_model_kind (x->ts.kind);
1292
1293 /* Get first recursion anchor. */
1294
1295 mpfr_init (last1);
1296 if (jn)
1297 mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE);
1298 else
1299 mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE);
1300
1301 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1302 mpfr_set (e->value.real, last1, GFC_RND_MODE);
1303 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1304 {
1305 mpfr_clear (last1);
1306 gfc_free_expr (e);
1307 gfc_free_expr (result);
1308 return &gfc_bad_expr;
1309 }
1310 gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1311
1312 if (n1 == n2)
1313 {
1314 mpfr_clear (last1);
1315 return result;
1316 }
8b704316 1317
29698e0f
TB		 1318 /* Get second recursion anchor. */
1319
1320 mpfr_init (last2);
1321 if (jn)
1322 mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE);
1323 else
1324 mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE);
1325
1326 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1327 mpfr_set (e->value.real, last2, GFC_RND_MODE);
1328 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1329 {
1330 mpfr_clear (last1);
1331 mpfr_clear (last2);
1332 gfc_free_expr (e);
1333 gfc_free_expr (result);
1334 return &gfc_bad_expr;
1335 }
1336 if (jn)
4c6e913c 1337 gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
8b704316 1338 else
29698e0f
TB		 1339 gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1340
1341 if (n1 + 1 == n2)
1342 {
1343 mpfr_clear (last1);
1344 mpfr_clear (last2);
1345 return result;
1346 }
1347
1348 /* Start actual recursion. */
1349
1350 mpfr_init (x2rev);
1351 mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
8b704316 1352
29698e0f
TB		 1353 for (i = 2; i <= n2-n1; i++)
1354 {
1355 e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
47b99694
TB		 1356
1357 /* Special case: For YN, if the previous N gave -INF, set
1358 also N+1 to -INF. */
1359 if (!jn && !gfc_option.flag_range_check && mpfr_inf_p (last2))
1360 {
1361 mpfr_set_inf (e->value.real, -1);
1362 gfc_constructor_append_expr (&result->value.constructor, e,
1363 &x->where);
1364 continue;
1365 }
1366
29698e0f
TB		 1367 mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1),
1368 GFC_RND_MODE);
1369 mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE);
1370 mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE);
1371
1372 if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
fd2805e1
TB		 1373 {
1374 /* Range_check frees "e" in that case. */
1375 e = NULL;
1376 goto error;
1377 }
29698e0f
TB		 1378
1379 if (jn)
1380 gfc_constructor_insert_expr (&result->value.constructor, e, &x->where,
1381 -i-1);
1382 else
1383 gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1384
1385 mpfr_set (last1, last2, GFC_RND_MODE);
1386 mpfr_set (last2, e->value.real, GFC_RND_MODE);
1387 }
1388
1389 mpfr_clear (last1);
1390 mpfr_clear (last2);
1391 mpfr_clear (x2rev);
1392 return result;
1393
1394error:
1395 mpfr_clear (last1);
1396 mpfr_clear (last2);
1397 mpfr_clear (x2rev);
1398 gfc_free_expr (e);
1399 gfc_free_expr (result);
1400 return &gfc_bad_expr;
1401}
1402
1403
1404gfc_expr *
1405gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1406{
1407 return gfc_simplify_bessel_n2 (order1, order2, x, true);
1408}
1409
1410
3c3f4265 1411gfc_expr *
b7e75771 1412gfc_simplify_bessel_y0 (gfc_expr *x)
3c3f4265 1413{
3c3f4265
TB		 1414 gfc_expr *result;
1415
1416 if (x->expr_type != EXPR_CONSTANT)
1417 return NULL;
1418
b7e75771 1419 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3c3f4265
TB		 1420 mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
1421
1422 return range_check (result, "BESSEL_Y0");
3c3f4265
TB		 1423}
1424
1425
1426gfc_expr *
b7e75771 1427gfc_simplify_bessel_y1 (gfc_expr *x)
3c3f4265 1428{
3c3f4265
TB		 1429 gfc_expr *result;
1430
1431 if (x->expr_type != EXPR_CONSTANT)
1432 return NULL;
1433
b7e75771 1434 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3c3f4265
TB		 1435 mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
1436
1437 return range_check (result, "BESSEL_Y1");
3c3f4265
TB		 1438}
1439
1440
1441gfc_expr *
b7e75771 1442gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
3c3f4265 1443{
3c3f4265
TB		 1444 gfc_expr *result;
1445 long n;
1446
1447 if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1448 return NULL;
1449
1450 n = mpz_get_si (order->value.integer);
b7e75771 1451 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3c3f4265
TB		 1452 mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
1453
1454 return range_check (result, "BESSEL_YN");
3c3f4265
TB		 1455}
1456
1457
29698e0f
TB		 1458gfc_expr *
1459gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1460{
1461 return gfc_simplify_bessel_n2 (order1, order2, x, false);
1462}
1463
1464
6de9cd9a 1465gfc_expr *
edf1eac2 1466gfc_simplify_bit_size (gfc_expr *e)
6de9cd9a 1467{
b7e75771
JD		 1468 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1469 return gfc_get_int_expr (e->ts.kind, &e->where,
1470 gfc_integer_kinds[i].bit_size);
6de9cd9a
DN		 1471}
1472
1473
1474gfc_expr *
edf1eac2 1475gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
6de9cd9a
DN		 1476{
1477 int b;
1478
1479 if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
1480 return NULL;
1481
1482 if (gfc_extract_int (bit, &b) != NULL || b < 0)
b7e75771 1483 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
6de9cd9a 1484
b7e75771
JD		 1485 return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
1486 mpz_tstbit (e->value.integer, b));
6de9cd9a
DN		 1487}
1488
1489
88a95a11
FXC		 1490static int
1491compare_bitwise (gfc_expr *i, gfc_expr *j)
1492{
1493 mpz_t x, y;
1494 int k, res;
1495
1496 gcc_assert (i->ts.type == BT_INTEGER);
1497 gcc_assert (j->ts.type == BT_INTEGER);
1498
1499 mpz_init_set (x, i->value.integer);
1500 k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
1501 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
1502
1503 mpz_init_set (y, j->value.integer);
1504 k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
1505 convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
1506
1507 res = mpz_cmp (x, y);
1508 mpz_clear (x);
1509 mpz_clear (y);
1510 return res;
1511}
1512
1513
1514gfc_expr *
1515gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
1516{
1517 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1518 return NULL;
1519
1520 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1521 compare_bitwise (i, j) >= 0);
1522}
1523
1524
1525gfc_expr *
1526gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
1527{
1528 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1529 return NULL;
1530
1531 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1532 compare_bitwise (i, j) > 0);
1533}
1534
1535
1536gfc_expr *
1537gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
1538{
1539 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1540 return NULL;
1541
1542 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1543 compare_bitwise (i, j) <= 0);
1544}
1545
1546
1547gfc_expr *
1548gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
1549{
1550 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1551 return NULL;
1552
1553 return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1554 compare_bitwise (i, j) < 0);
1555}
1556
1557
6de9cd9a 1558gfc_expr *
edf1eac2 1559gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
6de9cd9a
DN		 1560{
1561 gfc_expr *ceil, *result;
1562 int kind;
1563
145cf79b 1564 kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
6de9cd9a
DN		 1565 if (kind == -1)
1566 return &gfc_bad_expr;
1567
1568 if (e->expr_type != EXPR_CONSTANT)
1569 return NULL;
1570
6de9cd9a 1571 ceil = gfc_copy_expr (e);
f8e566e5 1572 mpfr_ceil (ceil->value.real, e->value.real);
b7e75771
JD		 1573
1574 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
7278e4dc 1575 gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
6de9cd9a
DN		 1576
1577 gfc_free_expr (ceil);
1578
1579 return range_check (result, "CEILING");
1580}
1581
1582
1583gfc_expr *
edf1eac2 1584gfc_simplify_char (gfc_expr *e, gfc_expr *k)
6de9cd9a 1585{
d393bbd7 1586 return simplify_achar_char (e, k, "CHAR", false);
6de9cd9a
DN		 1587}
1588
1589
b7e75771 1590/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
6de9cd9a
DN		 1591
1592static gfc_expr *
edf1eac2 1593simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
6de9cd9a
DN		 1594{
1595 gfc_expr *result;
1596
b7e75771
JD		 1597 if (convert_boz (x, kind) == &gfc_bad_expr)
1598 return &gfc_bad_expr;
1599
1600 if (convert_boz (y, kind) == &gfc_bad_expr)
1601 return &gfc_bad_expr;
1602
1603 if (x->expr_type != EXPR_CONSTANT
1604 || (y != NULL && y->expr_type != EXPR_CONSTANT))
1605 return NULL;
1606
1607 result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
6de9cd9a 1608
6de9cd9a
DN		 1609 switch (x->ts.type)
1610 {
b7e75771 1611 case BT_INTEGER:
eb6f9a86 1612 mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
b7e75771 1613 break;
6de9cd9a 1614
b7e75771
JD		 1615 case BT_REAL:
1616 mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
1617 break;
6de9cd9a 1618
b7e75771
JD		 1619 case BT_COMPLEX:
1620 mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1621 break;
6de9cd9a 1622
b7e75771
JD		 1623 default:
1624 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
6de9cd9a
DN		 1625 }
1626
b7e75771
JD		 1627 if (!y)
1628 return range_check (result, name);
6de9cd9a 1629
b7e75771 1630 switch (y->ts.type)
00a4618b 1631 {
b7e75771
JD		 1632 case BT_INTEGER:
1633 mpfr_set_z (mpc_imagref (result->value.complex),
1634 y->value.integer, GFC_RND_MODE);
1635 break;
00a4618b 1636
b7e75771
JD		 1637 case BT_REAL:
1638 mpfr_set (mpc_imagref (result->value.complex),
1639 y->value.real, GFC_RND_MODE);
1640 break;
1641
1642 default:
1643 gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
00a4618b
TB		 1644 }
1645
6de9cd9a
DN		 1646 return range_check (result, name);
1647}
1648
1649
1650gfc_expr *
edf1eac2 1651gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
6de9cd9a
DN		 1652{
1653 int kind;
1654
b7e75771 1655 kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
6de9cd9a
DN		 1656 if (kind == -1)
1657 return &gfc_bad_expr;
1658
1659 return simplify_cmplx ("CMPLX", x, y, kind);
1660}
1661
1662
5d723e54 1663gfc_expr *
edf1eac2 1664gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
5d723e54
FXC		 1665{
1666 int kind;
1667
b7e75771
JD		 1668 if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
1669 kind = gfc_default_complex_kind;
1670 else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
1671 kind = x->ts.kind;
1672 else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
1673 kind = y->ts.kind;
1674 else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
1675 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
5d723e54 1676 else
b7e75771 1677 gcc_unreachable ();
6401bf9c 1678
5d723e54
FXC		 1679 return simplify_cmplx ("COMPLEX", x, y, kind);
1680}
1681
1682
6de9cd9a 1683gfc_expr *
edf1eac2 1684gfc_simplify_conjg (gfc_expr *e)
6de9cd9a
DN		 1685{
1686 gfc_expr *result;
1687
1688 if (e->expr_type != EXPR_CONSTANT)
1689 return NULL;
1690
1691 result = gfc_copy_expr (e);
eb6f9a86 1692 mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
b7e75771 1693
6de9cd9a
DN		 1694 return range_check (result, "CONJG");
1695}
1696
1697
1698gfc_expr *
edf1eac2 1699gfc_simplify_cos (gfc_expr *x)
6de9cd9a
DN		 1700{
1701 gfc_expr *result;
6de9cd9a
DN		 1702
1703 if (x->expr_type != EXPR_CONSTANT)
1704 return NULL;
1705
b7e75771 1706 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6de9cd9a
DN		 1707
1708 switch (x->ts.type)
1709 {
b7e75771
JD		 1710 case BT_REAL:
1711 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1712 break;
1713
1714 case BT_COMPLEX:
1715 gfc_set_model_kind (x->ts.kind);
1716 mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1717 break;
1718
1719 default:
1720 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
6de9cd9a
DN		 1721 }
1722
1723 return range_check (result, "COS");
6de9cd9a
DN		 1724}
1725
1726
1727gfc_expr *
edf1eac2 1728gfc_simplify_cosh (gfc_expr *x)
6de9cd9a
DN		 1729{
1730 gfc_expr *result;
1731
1732 if (x->expr_type != EXPR_CONSTANT)
1733 return NULL;
1734
b7e75771 1735 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6de9cd9a 1736
b7e75771
JD		 1737 switch (x->ts.type)
1738 {
1739 case BT_REAL:
1740 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1741 break;
1742
1743 case BT_COMPLEX:
1744 mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1745 break;
8b704316 1746
b7e75771
JD		 1747 default:
1748 gcc_unreachable ();
1749 }
6de9cd9a
DN		 1750
1751 return range_check (result, "COSH");
1752}
1753
1754
a16d978f
DF		 1755gfc_expr *
1756gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1757{
1758 gfc_expr *result;
1759
1760 if (!is_constant_array_expr (mask)
1761 || !gfc_is_constant_expr (dim)
1762 || !gfc_is_constant_expr (kind))
1763 return NULL;
1764
1765 result = transformational_result (mask, dim,
1766 BT_INTEGER,
1767 get_kind (BT_INTEGER, kind, "COUNT",
1768 gfc_default_integer_kind),
1769 &mask->where);
1770
1771 init_result_expr (result, 0, NULL);
1772
1773 /* Passing MASK twice, once as data array, once as mask.
1774 Whenever gfc_count is called, '1' is added to the result. */
1775 return !dim || mask->rank == 1 ?
1776 simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
0cd0559e 1777 simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
a16d978f
DF		 1778}
1779
1780
6de9cd9a 1781gfc_expr *
edf1eac2 1782gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
6de9cd9a 1783{
9d64df18 1784 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
6de9cd9a
DN		 1785}
1786
1787
1788gfc_expr *
edf1eac2 1789gfc_simplify_dble (gfc_expr *e)
6de9cd9a 1790{
9e23c1aa 1791 gfc_expr *result = NULL;
6de9cd9a
DN		 1792
1793 if (e->expr_type != EXPR_CONSTANT)
1794 return NULL;
1795
b7e75771
JD		 1796 if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
1797 return &gfc_bad_expr;
6de9cd9a 1798
b7e75771
JD		 1799 result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
1800 if (result == &gfc_bad_expr)
1801 return &gfc_bad_expr;
00a4618b 1802
6de9cd9a
DN		 1803 return range_check (result, "DBLE");
1804}
1805
1806
1807gfc_expr *
edf1eac2 1808gfc_simplify_digits (gfc_expr *x)
6de9cd9a
DN		 1809{
1810 int i, digits;
1811
e7a2d5fb 1812 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
b7e75771 1813
6de9cd9a
DN		 1814 switch (x->ts.type)
1815 {
b7e75771
JD		 1816 case BT_INTEGER:
1817 digits = gfc_integer_kinds[i].digits;
1818 break;
6de9cd9a 1819
b7e75771
JD		 1820 case BT_REAL:
1821 case BT_COMPLEX:
1822 digits = gfc_real_kinds[i].digits;
1823 break;
6de9cd9a 1824
b7e75771
JD		 1825 default:
1826 gcc_unreachable ();
6de9cd9a
DN		 1827 }
1828
b7e75771 1829 return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
6de9cd9a
DN		 1830}
1831
1832
1833gfc_expr *
edf1eac2 1834gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
6de9cd9a
DN		 1835{
1836 gfc_expr *result;
991bb832 1837 int kind;
6de9cd9a
DN		 1838
1839 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1840 return NULL;
1841
991bb832 1842 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
b7e75771 1843 result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
6de9cd9a
DN		 1844
1845 switch (x->ts.type)
1846 {
b7e75771
JD		 1847 case BT_INTEGER:
1848 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
1849 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
1850 else
1851 mpz_set_ui (result->value.integer, 0);
6de9cd9a 1852
b7e75771 1853 break;
6de9cd9a 1854
b7e75771
JD		 1855 case BT_REAL:
1856 if (mpfr_cmp (x->value.real, y->value.real) > 0)
1857 mpfr_sub (result->value.real, x->value.real, y->value.real,
1858 GFC_RND_MODE);
1859 else
1860 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
6de9cd9a 1861
b7e75771 1862 break;
6de9cd9a 1863
b7e75771
JD		 1864 default:
1865 gfc_internal_error ("gfc_simplify_dim(): Bad type");
6de9cd9a
DN		 1866 }
1867
1868 return range_check (result, "DIM");
1869}
1870
1871
8ec259c1
DF		 1872gfc_expr*
1873gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
1874{
8ec259c1
DF		 1875 if (!is_constant_array_expr (vector_a)
1876 || !is_constant_array_expr (vector_b))
1877 return NULL;
1878
1879 gcc_assert (vector_a->rank == 1);
1880 gcc_assert (vector_b->rank == 1);
1881 gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
1882
b7e75771 1883 return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0);
8ec259c1
DF		 1884}
1885
1886
6de9cd9a 1887gfc_expr *
edf1eac2 1888gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
6de9cd9a 1889{
f8e566e5 1890 gfc_expr *a1, *a2, *result;
6de9cd9a
DN		 1891
1892 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1893 return NULL;
1894
9d64df18
TS		 1895 a1 = gfc_real2real (x, gfc_default_double_kind);
1896 a2 = gfc_real2real (y, gfc_default_double_kind);
6de9cd9a 1897
b7e75771 1898 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
f8e566e5 1899 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
6de9cd9a 1900
f8e566e5 1901 gfc_free_expr (a2);
b7e75771 1902 gfc_free_expr (a1);
6de9cd9a
DN		 1903
1904 return range_check (result, "DPROD");
1905}
1906
1907
88a95a11
FXC		 1908static gfc_expr *
1909simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
1910 bool right)
1911{
1912 gfc_expr *result;
1913 int i, k, size, shift;
1914
1915 if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
1916 || shiftarg->expr_type != EXPR_CONSTANT)
1917 return NULL;
1918
1919 k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
1920 size = gfc_integer_kinds[k].bit_size;
1921
58a9e3c4 1922 gfc_extract_int (shiftarg, &shift);
88a95a11
FXC		 1923
1924 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
1925 if (right)
1926 shift = size - shift;
1927
1928 result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
1929 mpz_set_ui (result->value.integer, 0);
1930
1931 for (i = 0; i < shift; i++)
1932 if (mpz_tstbit (arg2->value.integer, size - shift + i))
1933 mpz_setbit (result->value.integer, i);
1934
1935 for (i = 0; i < size - shift; i++)
1936 if (mpz_tstbit (arg1->value.integer, i))
1937 mpz_setbit (result->value.integer, shift + i);
1938
1939 /* Convert to a signed value. */
1940 convert_mpz_to_signed (result->value.integer, size);
1941
1942 return result;
1943}
1944
1945
1946gfc_expr *
1947gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
1948{
1949 return simplify_dshift (arg1, arg2, shiftarg, true);
1950}
1951
1952
1953gfc_expr *
1954gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
1955{
1956 return simplify_dshift (arg1, arg2, shiftarg, false);
1957}
1958
1959
fdc54e88
FXC		 1960gfc_expr *
1961gfc_simplify_erf (gfc_expr *x)
1962{
1963 gfc_expr *result;
1964
1965 if (x->expr_type != EXPR_CONSTANT)
1966 return NULL;
1967
b7e75771 1968 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
fdc54e88
FXC		 1969 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
1970
1971 return range_check (result, "ERF");
1972}
1973
1974
1975gfc_expr *
1976gfc_simplify_erfc (gfc_expr *x)
1977{
1978 gfc_expr *result;
1979
1980 if (x->expr_type != EXPR_CONSTANT)
1981 return NULL;
1982
b7e75771 1983 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
fdc54e88
FXC		 1984 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
1985
1986 return range_check (result, "ERFC");
1987}
1988
1989
9b33a6a1
FXC		 1990/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
1991
1992#define MAX_ITER 200
1993#define ARG_LIMIT 12
1994
1995/* Calculate ERFC_SCALED directly by its definition:
1996
1997 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
1998
1999 using a large precision for intermediate results. This is used for all
2000 but large values of the argument. */
2001static void
2002fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
2003{
2004 mp_prec_t prec;
2005 mpfr_t a, b;
2006
2007 prec = mpfr_get_default_prec ();
2008 mpfr_set_default_prec (10 * prec);
2009
2010 mpfr_init (a);
2011 mpfr_init (b);
2012
2013 mpfr_set (a, arg, GFC_RND_MODE);
2014 mpfr_sqr (b, a, GFC_RND_MODE);
2015 mpfr_exp (b, b, GFC_RND_MODE);
2016 mpfr_erfc (a, a, GFC_RND_MODE);
2017 mpfr_mul (a, a, b, GFC_RND_MODE);
2018
2019 mpfr_set (res, a, GFC_RND_MODE);
2020 mpfr_set_default_prec (prec);
2021
2022 mpfr_clear (a);
2023 mpfr_clear (b);
2024}
2025
2026/* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2027
2028 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2029 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2030 / (2 * x**2)**n)
2031
2032 This is used for large values of the argument. Intermediate calculations
2033 are performed with twice the precision. We don't do a fixed number of
2034 iterations of the sum, but stop when it has converged to the required
2035 precision. */
2036static void
2037asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
2038{
2039 mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
2040 mpz_t num;
2041 mp_prec_t prec;
2042 unsigned i;
2043
2044 prec = mpfr_get_default_prec ();
2045 mpfr_set_default_prec (2 * prec);
2046
2047 mpfr_init (sum);
2048 mpfr_init (x);
2049 mpfr_init (u);
2050 mpfr_init (v);
2051 mpfr_init (w);
2052 mpz_init (num);
2053
2054 mpfr_init (oldsum);
2055 mpfr_init (sumtrunc);
2056 mpfr_set_prec (oldsum, prec);
2057 mpfr_set_prec (sumtrunc, prec);
2058
2059 mpfr_set (x, arg, GFC_RND_MODE);
2060 mpfr_set_ui (sum, 1, GFC_RND_MODE);
2061 mpz_set_ui (num, 1);
2062
2063 mpfr_set (u, x, GFC_RND_MODE);
2064 mpfr_sqr (u, u, GFC_RND_MODE);
2065 mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
2066 mpfr_pow_si (u, u, -1, GFC_RND_MODE);
2067
2068 for (i = 1; i < MAX_ITER; i++)
2069 {
2070 mpfr_set (oldsum, sum, GFC_RND_MODE);
2071
2072 mpz_mul_ui (num, num, 2 * i - 1);
2073 mpz_neg (num, num);
2074
2075 mpfr_set (w, u, GFC_RND_MODE);
2076 mpfr_pow_ui (w, w, i, GFC_RND_MODE);
2077
2078 mpfr_set_z (v, num, GFC_RND_MODE);
2079 mpfr_mul (v, v, w, GFC_RND_MODE);
2080
2081 mpfr_add (sum, sum, v, GFC_RND_MODE);
2082
2083 mpfr_set (sumtrunc, sum, GFC_RND_MODE);
2084 if (mpfr_cmp (sumtrunc, oldsum) == 0)
2085 break;
2086 }
2087
2088 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2089 set too low. */
2090 gcc_assert (i < MAX_ITER);
2091
2092 /* Divide by x * sqrt(Pi). */
2093 mpfr_const_pi (u, GFC_RND_MODE);
2094 mpfr_sqrt (u, u, GFC_RND_MODE);
2095 mpfr_mul (u, u, x, GFC_RND_MODE);
2096 mpfr_div (sum, sum, u, GFC_RND_MODE);
2097
2098 mpfr_set (res, sum, GFC_RND_MODE);
2099 mpfr_set_default_prec (prec);
2100
2101 mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
2102 mpz_clear (num);
2103}
2104
2105
2106gfc_expr *
2107gfc_simplify_erfc_scaled (gfc_expr *x)
2108{
2109 gfc_expr *result;
2110
2111 if (x->expr_type != EXPR_CONSTANT)
2112 return NULL;
2113
b7e75771 2114 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
9b33a6a1
FXC		 2115 if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
2116 asympt_erfc_scaled (result->value.real, x->value.real);
2117 else
2118 fullprec_erfc_scaled (result->value.real, x->value.real);
2119
2120 return range_check (result, "ERFC_SCALED");
2121}
2122
2123#undef MAX_ITER
2124#undef ARG_LIMIT
2125
2126
6de9cd9a 2127gfc_expr *
edf1eac2 2128gfc_simplify_epsilon (gfc_expr *e)
6de9cd9a
DN		 2129{
2130 gfc_expr *result;
2131 int i;
2132
e7a2d5fb 2133 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6de9cd9a 2134
b7e75771 2135 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
f8e566e5 2136 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
6de9cd9a
DN		 2137
2138 return range_check (result, "EPSILON");
2139}
2140
2141
2142gfc_expr *
edf1eac2 2143gfc_simplify_exp (gfc_expr *x)
6de9cd9a
DN		 2144{
2145 gfc_expr *result;
6de9cd9a
DN		 2146
2147 if (x->expr_type != EXPR_CONSTANT)
2148 return NULL;
2149
b7e75771 2150 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6de9cd9a 2151
6de9cd9a
DN		 2152 switch (x->ts.type)
2153 {
b7e75771
JD		 2154 case BT_REAL:
2155 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
2156 break;
6de9cd9a 2157
b7e75771
JD		 2158 case BT_COMPLEX:
2159 gfc_set_model_kind (x->ts.kind);
2160 mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
2161 break;
6de9cd9a 2162
b7e75771
JD		 2163 default:
2164 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
6de9cd9a
DN		 2165 }
2166
2167 return range_check (result, "EXP");
2168}
2169
d0a4a61c 2170
6de9cd9a 2171gfc_expr *
edf1eac2 2172gfc_simplify_exponent (gfc_expr *x)
6de9cd9a 2173{
01ae8930 2174 int i;
6de9cd9a
DN		 2175 gfc_expr *result;
2176
2177 if (x->expr_type != EXPR_CONSTANT)
2178 return NULL;
2179
b7e75771
JD		 2180 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2181 &x->where);
6de9cd9a 2182
f8e566e5 2183 gfc_set_model (x->value.real);
f8e566e5 2184
03ddaf35 2185 if (mpfr_sgn (x->value.real) == 0)
6de9cd9a
DN		 2186 {
2187 mpz_set_ui (result->value.integer, 0);
2188 return result;
2189 }
2190
e48d66a9
SK		 2191 i = (int) mpfr_get_exp (x->value.real);
2192 mpz_set_si (result->value.integer, i);
6de9cd9a
DN		 2193
2194 return range_check (result, "EXPONENT");
2195}
2196
2197
2198gfc_expr *
edf1eac2 2199gfc_simplify_float (gfc_expr *a)
6de9cd9a
DN		 2200{
2201 gfc_expr *result;
2202
2203 if (a->expr_type != EXPR_CONSTANT)
2204 return NULL;
2205
00a4618b
TB		 2206 if (a->is_boz)
2207 {
b7e75771
JD		 2208 if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
2209 return &gfc_bad_expr;
00a4618b
TB		 2210
2211 result = gfc_copy_expr (a);
00a4618b
TB		 2212 }
2213 else
2214 result = gfc_int2real (a, gfc_default_real_kind);
b7e75771 2215
6de9cd9a
DN		 2216 return range_check (result, "FLOAT");
2217}
2218
2219
eaf31d82
TB		 2220static bool
2221is_last_ref_vtab (gfc_expr *e)
2222{
2223 gfc_ref *ref;
2224 gfc_component *comp = NULL;
2225
2226 if (e->expr_type != EXPR_VARIABLE)
2227 return false;
2228
2229 for (ref = e->ref; ref; ref = ref->next)
2230 if (ref->type == REF_COMPONENT)
2231 comp = ref->u.c.component;
2232
2233 if (!e->ref || !comp)
2234 return e->symtree->n.sym->attr.vtab;
2235
2236 if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
2237 return true;
2238
2239 return false;
2240}
2241
2242
2243gfc_expr *
2244gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
2245{
2246 /* Avoid simplification of resolved symbols. */
2247 if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
2248 return NULL;
2249
2250 if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
2251 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
2252 gfc_type_is_extension_of (mold->ts.u.derived,
2253 a->ts.u.derived));
8b704316
PT		 2254
2255 if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
2256 return NULL;
2257
eaf31d82
TB		 2258 /* Return .false. if the dynamic type can never be the same. */
2259 if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
2260 && !gfc_type_is_extension_of
2261 (mold->ts.u.derived->components->ts.u.derived,
2262 a->ts.u.derived->components->ts.u.derived)
2263 && !gfc_type_is_extension_of
2264 (a->ts.u.derived->components->ts.u.derived,
2265 mold->ts.u.derived->components->ts.u.derived))
2266 || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
2267 && !gfc_type_is_extension_of
2268 (a->ts.u.derived,
2269 mold->ts.u.derived->components->ts.u.derived)
2270 && !gfc_type_is_extension_of
2271 (mold->ts.u.derived->components->ts.u.derived,
2272 a->ts.u.derived))
2273 || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
2274 && !gfc_type_is_extension_of
2275 (mold->ts.u.derived,
2276 a->ts.u.derived->components->ts.u.derived)))
2277 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
2278
2279 if (mold->ts.type == BT_DERIVED
2280 && gfc_type_is_extension_of (mold->ts.u.derived,
2281 a->ts.u.derived->components->ts.u.derived))
2282 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
2283
2284 return NULL;
2285}
2286
2287
2288gfc_expr *
2289gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
2290{
2291 /* Avoid simplification of resolved symbols. */
2292 if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
2293 return NULL;
2294
2295 /* Return .false. if the dynamic type can never be the
2296 same. */
2297 if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS)
2298 && !gfc_type_compatible (&a->ts, &b->ts)
2299 && !gfc_type_compatible (&b->ts, &a->ts))
2300 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
2301
2302 if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
2303 return NULL;
2304
2305 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
2306 gfc_compare_derived_types (a->ts.u.derived,
2307 b->ts.u.derived));
2308}
2309
2310
6de9cd9a 2311gfc_expr *
edf1eac2 2312gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
6de9cd9a
DN		 2313{
2314 gfc_expr *result;
f8e566e5 2315 mpfr_t floor;
6de9cd9a
DN		 2316 int kind;
2317
145cf79b 2318 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
6de9cd9a
DN		 2319 if (kind == -1)
2320 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2321
2322 if (e->expr_type != EXPR_CONSTANT)
2323 return NULL;
2324
f8e566e5 2325 gfc_set_model_kind (kind);
b7e75771 2326
f8e566e5
SK		 2327 mpfr_init (floor);
2328 mpfr_floor (floor, e->value.real);
2329
b7e75771 2330 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
7278e4dc 2331 gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
f8e566e5
SK		 2332
2333 mpfr_clear (floor);
6de9cd9a
DN		 2334
2335 return range_check (result, "FLOOR");
2336}
2337
2338
2339gfc_expr *
edf1eac2 2340gfc_simplify_fraction (gfc_expr *x)
6de9cd9a
DN		 2341{
2342 gfc_expr *result;
03ddaf35 2343 mpfr_t absv, exp, pow2;
6de9cd9a
DN		 2344
2345 if (x->expr_type != EXPR_CONSTANT)
2346 return NULL;
2347
b7e75771 2348 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
6de9cd9a 2349
03ddaf35 2350 if (mpfr_sgn (x->value.real) == 0)
6de9cd9a 2351 {
03ddaf35 2352 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
6de9cd9a
DN		 2353 return result;
2354 }
2355
7306494a 2356 gfc_set_model_kind (x->ts.kind);
03ddaf35 2357 mpfr_init (exp);
f8e566e5 2358 mpfr_init (absv);
f8e566e5 2359 mpfr_init (pow2);
6de9cd9a 2360
f8e566e5 2361 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
03ddaf35 2362 mpfr_log2 (exp, absv, GFC_RND_MODE);
6de9cd9a 2363
03ddaf35
TS		 2364 mpfr_trunc (exp, exp);
2365 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
6de9cd9a 2366
03ddaf35 2367 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
6de9cd9a 2368
f8e566e5 2369 mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
6de9cd9a 2370
7306494a 2371 mpfr_clears (exp, absv, pow2, NULL);
6de9cd9a
DN		 2372
2373 return range_check (result, "FRACTION");
2374}
2375
2376
75be5dc0
TB		 2377gfc_expr *
2378gfc_simplify_gamma (gfc_expr *x)
2379{
2380 gfc_expr *result;
2381
2382 if (x->expr_type != EXPR_CONSTANT)
2383 return NULL;
2384
b7e75771 2385 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
75be5dc0
TB		 2386 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
2387
2388 return range_check (result, "GAMMA");
2389}
2390
2391
6de9cd9a 2392gfc_expr *
edf1eac2 2393gfc_simplify_huge (gfc_expr *e)
6de9cd9a
DN		 2394{
2395 gfc_expr *result;
2396 int i;
2397
e7a2d5fb 2398 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
b7e75771 2399 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6de9cd9a
DN		 2400
2401 switch (e->ts.type)
2402 {
b7e75771
JD		 2403 case BT_INTEGER:
2404 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
2405 break;
6de9cd9a 2406
b7e75771
JD		 2407 case BT_REAL:
2408 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
2409 break;
6de9cd9a 2410
b7e75771
JD		 2411 default:
2412 gcc_unreachable ();
6de9cd9a
DN		 2413 }
2414
2415 return result;
2416}
2417
f489fba1
FXC		 2418
2419gfc_expr *
2420gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
2421{
2422 gfc_expr *result;
2423
2424 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2425 return NULL;
2426
b7e75771 2427 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
f489fba1
FXC		 2428 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
2429 return range_check (result, "HYPOT");
2430}
2431
2432
34462c28 2433/* We use the processor's collating sequence, because all
65de695f 2434 systems that gfortran currently works on are ASCII. */
6de9cd9a
DN		 2435
2436gfc_expr *
5cda5098 2437gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
6de9cd9a
DN		 2438{
2439 gfc_expr *result;
00660189 2440 gfc_char_t index;
b7e75771 2441 int k;
6de9cd9a
DN		 2442
2443 if (e->expr_type != EXPR_CONSTANT)
2444 return NULL;
2445
2446 if (e->value.character.length != 1)
2447 {
2448 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
2449 return &gfc_bad_expr;
2450 }
2451
00660189 2452 index = e->value.character.string[0];
34462c28
TK		 2453
2454 if (gfc_option.warn_surprising && index > 127)
2455 gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
2456 &e->where);
6de9cd9a 2457
b7e75771
JD		 2458 k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
2459 if (k == -1)
5cda5098
FXC		 2460 return &gfc_bad_expr;
2461
b7e75771 2462 result = gfc_get_int_expr (k, &e->where, index);
6de9cd9a
DN		 2463
2464 return range_check (result, "IACHAR");
2465}
2466
2467
195a95c4
TB		 2468static gfc_expr *
2469do_bit_and (gfc_expr *result, gfc_expr *e)
2470{
2471 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
2472 gcc_assert (result->ts.type == BT_INTEGER
2473 && result->expr_type == EXPR_CONSTANT);
2474
2475 mpz_and (result->value.integer, result->value.integer, e->value.integer);
2476 return result;
2477}
2478
2479
2480gfc_expr *
2481gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2482{
2483 return simplify_transformation (array, dim, mask, -1, do_bit_and);
2484}
2485
2486
2487static gfc_expr *
2488do_bit_ior (gfc_expr *result, gfc_expr *e)
2489{
2490 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
2491 gcc_assert (result->ts.type == BT_INTEGER
2492 && result->expr_type == EXPR_CONSTANT);
2493
2494 mpz_ior (result->value.integer, result->value.integer, e->value.integer);
2495 return result;
2496}
2497
2498
2499gfc_expr *
2500gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2501{
2502 return simplify_transformation (array, dim, mask, 0, do_bit_ior);
2503}
2504
2505
6de9cd9a 2506gfc_expr *
edf1eac2 2507gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
6de9cd9a
DN		 2508{
2509 gfc_expr *result;
2510
2511 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2512 return NULL;
2513
b7e75771 2514 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
6de9cd9a
DN		 2515 mpz_and (result->value.integer, x->value.integer, y->value.integer);
2516
2517 return range_check (result, "IAND");
2518}
2519
2520
2521gfc_expr *
edf1eac2 2522gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
6de9cd9a
DN		 2523{
2524 gfc_expr *result;
2525 int k, pos;
2526
2527 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2528 return NULL;
2529
58a9e3c4 2530 gfc_extract_int (y, &pos);
6de9cd9a 2531
e7a2d5fb 2532 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6de9cd9a 2533
6de9cd9a
DN		 2534 result = gfc_copy_expr (x);
2535
f1dcb9bf
BM		 2536 convert_mpz_to_unsigned (result->value.integer,
2537 gfc_integer_kinds[k].bit_size);
2538
6de9cd9a 2539 mpz_clrbit (result->value.integer, pos);
f1dcb9bf
BM		 2540
2541 convert_mpz_to_signed (result->value.integer,
2542 gfc_integer_kinds[k].bit_size);
2543
c05800b6 2544 return result;
6de9cd9a
DN		 2545}
2546
2547
2548gfc_expr *
edf1eac2 2549gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
6de9cd9a
DN		 2550{
2551 gfc_expr *result;
2552 int pos, len;
2553 int i, k, bitsize;
2554 int *bits;
2555
2556 if (x->expr_type != EXPR_CONSTANT
2557 || y->expr_type != EXPR_CONSTANT
2558 || z->expr_type != EXPR_CONSTANT)
2559 return NULL;
2560
58a9e3c4
SK		 2561 gfc_extract_int (y, &pos);
2562 gfc_extract_int (z, &len);
6de9cd9a 2563
e7a2d5fb 2564 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
6de9cd9a
DN		 2565
2566 bitsize = gfc_integer_kinds[k].bit_size;
2567
2568 if (pos + len > bitsize)
2569 {
f1dcb9bf
BM		 2570 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2571 "bit size at %L", &y->where);
6de9cd9a
DN		 2572 return &gfc_bad_expr;
2573 }
2574
b7e75771 2575 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
c05800b6
JD		 2576 convert_mpz_to_unsigned (result->value.integer,
2577 gfc_integer_kinds[k].bit_size);
6de9cd9a 2578
ece3f663 2579 bits = XCNEWVEC (int, bitsize);
6de9cd9a
DN		 2580
2581 for (i = 0; i < bitsize; i++)
2582 bits[i] = 0;
2583
2584 for (i = 0; i < len; i++)
2585 bits[i] = mpz_tstbit (x->value.integer, i + pos);
2586
2587 for (i = 0; i < bitsize; i++)
2588 {
2589 if (bits[i] == 0)
edf1eac2 2590 mpz_clrbit (result->value.integer, i);
6de9cd9a 2591 else if (bits[i] == 1)
edf1eac2 2592 mpz_setbit (result->value.integer, i);
6de9cd9a 2593 else
edf1eac2 2594 gfc_internal_error ("IBITS: Bad bit");
6de9cd9a
DN		 2595 }
2596
cede9502 2597 free (bits);
6de9cd9a 2598
c05800b6
JD		 2599 convert_mpz_to_signed (result->value.integer,
2600 gfc_integer_kinds[k].bit_size);
2601
2602 return result;
6de9cd9a
DN		 2603}
2604
2605
2606gfc_expr *
edf1eac2 2607gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
6de9cd9a
DN		 2608{
2609 gfc_expr *result;
2610 int k, pos;
2611
2612 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2613 return NULL;
2614
58a9e3c4 2615 gfc_extract_int (y, &pos);
6de9cd9a 2616
e7a2d5fb 2617 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6de9cd9a 2618
6de9cd9a
DN		 2619 result = gfc_copy_expr (x);
2620
f1dcb9bf
BM		 2621 convert_mpz_to_unsigned (result->value.integer,
2622 gfc_integer_kinds[k].bit_size);
2623
6de9cd9a 2624 mpz_setbit (result->value.integer, pos);
ef98c52a 2625
f1dcb9bf
BM		 2626 convert_mpz_to_signed (result->value.integer,
2627 gfc_integer_kinds[k].bit_size);
ef98c52a 2628
c05800b6 2629 return result;
6de9cd9a
DN		 2630}
2631
2632
2633gfc_expr *
5cda5098 2634gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
6de9cd9a
DN		 2635{
2636 gfc_expr *result;
00660189 2637 gfc_char_t index;
b7e75771 2638 int k;
6de9cd9a
DN		 2639
2640 if (e->expr_type != EXPR_CONSTANT)
2641 return NULL;
2642
2643 if (e->value.character.length != 1)
2644 {
2645 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
2646 return &gfc_bad_expr;
2647 }
2648
00660189 2649 index = e->value.character.string[0];
6de9cd9a 2650
b7e75771
JD		 2651 k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
2652 if (k == -1)
5cda5098
FXC		 2653 return &gfc_bad_expr;
2654
b7e75771
JD		 2655 result = gfc_get_int_expr (k, &e->where, index);
2656
6de9cd9a
DN		 2657 return range_check (result, "ICHAR");
2658}
2659
2660
2661gfc_expr *
edf1eac2 2662gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
6de9cd9a
DN		 2663{
2664 gfc_expr *result;
2665
2666 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2667 return NULL;
2668
b7e75771 2669 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
6de9cd9a
DN		 2670 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
2671
2672 return range_check (result, "IEOR");
2673}
2674
2675
2676gfc_expr *
5cda5098 2677gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
6de9cd9a
DN		 2678{
2679 gfc_expr *result;
2680 int back, len, lensub;
2681 int i, j, k, count, index = 0, start;
2682
8b704316 2683 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
00113de8 2684 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
6de9cd9a
DN		 2685 return NULL;
2686
2687 if (b != NULL && b->value.logical != 0)
2688 back = 1;
2689 else
2690 back = 0;
2691
8b704316 2692 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
5cda5098
FXC		 2693 if (k == -1)
2694 return &gfc_bad_expr;
2695
b7e75771 2696 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
6de9cd9a
DN		 2697
2698 len = x->value.character.length;
2699 lensub = y->value.character.length;
2700
2701 if (len < lensub)
2702 {
2703 mpz_set_si (result->value.integer, 0);
2704 return result;
2705 }
2706
2707 if (back == 0)
2708 {
6de9cd9a
DN		 2709 if (lensub == 0)
2710 {
2711 mpz_set_si (result->value.integer, 1);
2712 return result;
2713 }
2714 else if (lensub == 1)
2715 {
2716 for (i = 0; i < len; i++)
2717 {
2718 for (j = 0; j < lensub; j++)
2719 {
edf1eac2
SK		 2720 if (y->value.character.string[j]
2721 == x->value.character.string[i])
6de9cd9a
DN		 2722 {
2723 index = i + 1;
2724 goto done;
2725 }
2726 }
2727 }
2728 }
2729 else
2730 {
2731 for (i = 0; i < len; i++)
2732 {
2733 for (j = 0; j < lensub; j++)
2734 {
edf1eac2
SK		 2735 if (y->value.character.string[j]
2736 == x->value.character.string[i])
6de9cd9a
DN		 2737 {
2738 start = i;
2739 count = 0;
2740
2741 for (k = 0; k < lensub; k++)
2742 {
edf1eac2
SK		 2743 if (y->value.character.string[k]
2744 == x->value.character.string[k + start])
6de9cd9a
DN		 2745 count++;
2746 }
2747
2748 if (count == lensub)
2749 {
2750 index = start + 1;
2751 goto done;
2752 }
2753 }
2754 }
2755 }
2756 }
2757
2758 }
2759 else
2760 {
6de9cd9a
DN		 2761 if (lensub == 0)
2762 {
2763 mpz_set_si (result->value.integer, len + 1);
2764 return result;
2765 }
2766 else if (lensub == 1)
2767 {
2768 for (i = 0; i < len; i++)
2769 {
2770 for (j = 0; j < lensub; j++)
2771 {
edf1eac2
SK		 2772 if (y->value.character.string[j]
2773 == x->value.character.string[len - i])
6de9cd9a
DN		 2774 {
2775 index = len - i + 1;
2776 goto done;
2777 }
2778 }
2779 }
2780 }
2781 else
2782 {
2783 for (i = 0; i < len; i++)
2784 {
2785 for (j = 0; j < lensub; j++)
2786 {
edf1eac2
SK		 2787 if (y->value.character.string[j]
2788 == x->value.character.string[len - i])
6de9cd9a
DN		 2789 {
2790 start = len - i;
2791 if (start <= len - lensub)
2792 {
2793 count = 0;
2794 for (k = 0; k < lensub; k++)
edf1eac2
SK		 2795 if (y->value.character.string[k]
2796 == x->value.character.string[k + start])
6de9cd9a
DN		 2797 count++;
2798
2799 if (count == lensub)
2800 {
2801 index = start + 1;
2802 goto done;
2803 }
2804 }
2805 else
2806 {
2807 continue;
2808 }
2809 }
2810 }
2811 }
2812 }
2813 }
2814
2815done:
2816 mpz_set_si (result->value.integer, index);
2817 return range_check (result, "INDEX");
2818}
2819
2820
b7e75771
JD		 2821static gfc_expr *
2822simplify_intconv (gfc_expr *e, int kind, const char *name)
6de9cd9a 2823{
d93712d9 2824 gfc_expr *result = NULL;
6de9cd9a
DN		 2825
2826 if (e->expr_type != EXPR_CONSTANT)
2827 return NULL;
2828
b7e75771
JD		 2829 result = gfc_convert_constant (e, BT_INTEGER, kind);
2830 if (result == &gfc_bad_expr)
2831 return &gfc_bad_expr;
6de9cd9a 2832
b7e75771 2833 return range_check (result, name);
6de9cd9a
DN		 2834}
2835
2836
b7e75771
JD		 2837gfc_expr *
2838gfc_simplify_int (gfc_expr *e, gfc_expr *k)
bf3fb7e4 2839{
b7e75771 2840 int kind;
bf3fb7e4 2841
b7e75771
JD		 2842 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
2843 if (kind == -1)
2844 return &gfc_bad_expr;
bf3fb7e4 2845
b7e75771 2846 return simplify_intconv (e, kind, "INT");
bf3fb7e4
FXC		 2847}
2848
2849gfc_expr *
edf1eac2 2850gfc_simplify_int2 (gfc_expr *e)
bf3fb7e4 2851{
d93712d9 2852 return simplify_intconv (e, 2, "INT2");
bf3fb7e4
FXC		 2853}
2854
edf1eac2 2855
bf3fb7e4 2856gfc_expr *
edf1eac2 2857gfc_simplify_int8 (gfc_expr *e)
bf3fb7e4 2858{
d93712d9 2859 return simplify_intconv (e, 8, "INT8");
bf3fb7e4
FXC		 2860}
2861
edf1eac2 2862
bf3fb7e4 2863gfc_expr *
edf1eac2 2864gfc_simplify_long (gfc_expr *e)
bf3fb7e4 2865{
d93712d9 2866 return simplify_intconv (e, 4, "LONG");
bf3fb7e4
FXC		 2867}
2868
2869
6de9cd9a 2870gfc_expr *
edf1eac2 2871gfc_simplify_ifix (gfc_expr *e)
6de9cd9a
DN		 2872{
2873 gfc_expr *rtrunc, *result;
2874
2875 if (e->expr_type != EXPR_CONSTANT)
2876 return NULL;
2877
6de9cd9a 2878 rtrunc = gfc_copy_expr (e);
f8e566e5 2879 mpfr_trunc (rtrunc->value.real, e->value.real);
b7e75771
JD		 2880
2881 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2882 &e->where);
7278e4dc 2883 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
6de9cd9a
DN		 2884
2885 gfc_free_expr (rtrunc);
b7e75771 2886
6de9cd9a
DN		 2887 return range_check (result, "IFIX");
2888}
2889
2890
2891gfc_expr *
edf1eac2 2892gfc_simplify_idint (gfc_expr *e)
6de9cd9a
DN		 2893{
2894 gfc_expr *rtrunc, *result;
2895
2896 if (e->expr_type != EXPR_CONSTANT)
2897 return NULL;
2898
6de9cd9a 2899 rtrunc = gfc_copy_expr (e);
f8e566e5 2900 mpfr_trunc (rtrunc->value.real, e->value.real);
b7e75771
JD		 2901
2902 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2903 &e->where);
7278e4dc 2904 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
6de9cd9a
DN		 2905
2906 gfc_free_expr (rtrunc);
b7e75771 2907
6de9cd9a
DN		 2908 return range_check (result, "IDINT");
2909}
2910
2911
2912gfc_expr *
edf1eac2 2913gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
6de9cd9a
DN		 2914{
2915 gfc_expr *result;
2916
2917 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2918 return NULL;
2919
b7e75771 2920 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
6de9cd9a 2921 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
b7e75771 2922
6de9cd9a
DN		 2923 return range_check (result, "IOR");
2924}
2925
2926
195a95c4
TB		 2927static gfc_expr *
2928do_bit_xor (gfc_expr *result, gfc_expr *e)
2929{
2930 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
2931 gcc_assert (result->ts.type == BT_INTEGER
2932 && result->expr_type == EXPR_CONSTANT);
2933
2934 mpz_xor (result->value.integer, result->value.integer, e->value.integer);
2935 return result;
2936}
2937
2938
2939gfc_expr *
2940gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2941{
2942 return simplify_transformation (array, dim, mask, 0, do_bit_xor);
2943}
2944
2945
4ec80803
FXC		 2946gfc_expr *
2947gfc_simplify_is_iostat_end (gfc_expr *x)
2948{
4ec80803
FXC		 2949 if (x->expr_type != EXPR_CONSTANT)
2950 return NULL;
2951
b7e75771
JD		 2952 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2953 mpz_cmp_si (x->value.integer,
2954 LIBERROR_END) == 0);
4ec80803
FXC		 2955}
2956
2957
2958gfc_expr *
2959gfc_simplify_is_iostat_eor (gfc_expr *x)
2960{
4ec80803
FXC		 2961 if (x->expr_type != EXPR_CONSTANT)
2962 return NULL;
2963
b7e75771
JD		 2964 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2965 mpz_cmp_si (x->value.integer,
2966 LIBERROR_EOR) == 0);
4ec80803
FXC		 2967}
2968
2969
2970gfc_expr *
2971gfc_simplify_isnan (gfc_expr *x)
2972{
4ec80803
FXC		 2973 if (x->expr_type != EXPR_CONSTANT)
2974 return NULL;
2975
b7e75771
JD		 2976 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
2977 mpfr_nan_p (x->value.real));
4ec80803
FXC		 2978}
2979
2980
88a95a11
FXC		 2981/* Performs a shift on its first argument. Depending on the last
2982 argument, the shift can be arithmetic, i.e. with filling from the
2983 left like in the SHIFTA intrinsic. */
2984static gfc_expr *
2985simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
2986 bool arithmetic, int direction)
6de9cd9a
DN		 2987{
2988 gfc_expr *result;
88a95a11 2989 int ashift, *bits, i, k, bitsize, shift;
6de9cd9a
DN		 2990
2991 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
2992 return NULL;
58a9e3c4
SK		 2993
2994 gfc_extract_int (s, &shift);
6de9cd9a 2995
e7a2d5fb 2996 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
88a95a11 2997 bitsize = gfc_integer_kinds[k].bit_size;
6de9cd9a 2998
88a95a11 2999 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6de9cd9a 3000
88a95a11
FXC		 3001 if (shift == 0)
3002 {
3003 mpz_set (result->value.integer, e->value.integer);
3004 return result;
3005 }
6de9cd9a 3006
88a95a11 3007 if (direction > 0 && shift < 0)
6de9cd9a 3008 {
88a95a11
FXC		 3009 /* Left shift, as in SHIFTL. */
3010 gfc_error ("Second argument of %s is negative at %L", name, &e->where);
6de9cd9a
DN		 3011 return &gfc_bad_expr;
3012 }
88a95a11
FXC		 3013 else if (direction < 0)
3014 {
3015 /* Right shift, as in SHIFTR or SHIFTA. */
3016 if (shift < 0)
3017 {
3018 gfc_error ("Second argument of %s is negative at %L",
3019 name, &e->where);
3020 return &gfc_bad_expr;
3021 }
6de9cd9a 3022
88a95a11
FXC		 3023 shift = -shift;
3024 }
6de9cd9a 3025
88a95a11
FXC		 3026 ashift = (shift >= 0 ? shift : -shift);
3027
3028 if (ashift > bitsize)
6de9cd9a 3029 {
88a95a11
FXC		 3030 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3031 "at %L", name, &e->where);
3032 return &gfc_bad_expr;
6de9cd9a 3033 }
5d24a977 3034
88a95a11
FXC		 3035 bits = XCNEWVEC (int, bitsize);
3036
3037 for (i = 0; i < bitsize; i++)
5d24a977 3038 bits[i] = mpz_tstbit (e->value.integer, i);
6de9cd9a
DN		 3039
3040 if (shift > 0)
5d24a977 3041 {
88a95a11 3042 /* Left shift. */
5d24a977
TS		 3043 for (i = 0; i < shift; i++)
3044 mpz_clrbit (result->value.integer, i);
3045
88a95a11 3046 for (i = 0; i < bitsize - shift; i++)
5d24a977
TS		 3047 {
3048 if (bits[i] == 0)
3049 mpz_clrbit (result->value.integer, i + shift);
3050 else
3051 mpz_setbit (result->value.integer, i + shift);
3052 }
3053 }
6de9cd9a 3054 else
5d24a977 3055 {
88a95a11
FXC		 3056 /* Right shift. */
3057 if (arithmetic && bits[bitsize - 1])
3058 for (i = bitsize - 1; i >= bitsize - ashift; i--)
3059 mpz_setbit (result->value.integer, i);
3060 else
3061 for (i = bitsize - 1; i >= bitsize - ashift; i--)
3062 mpz_clrbit (result->value.integer, i);
5d24a977 3063
88a95a11 3064 for (i = bitsize - 1; i >= ashift; i--)
5d24a977
TS		 3065 {
3066 if (bits[i] == 0)
3067 mpz_clrbit (result->value.integer, i - ashift);
3068 else
3069 mpz_setbit (result->value.integer, i - ashift);
3070 }
3071 }
6de9cd9a 3072
88a95a11 3073 convert_mpz_to_signed (result->value.integer, bitsize);
cede9502 3074 free (bits);
88a95a11 3075
5d24a977 3076 return result;
6de9cd9a
DN		 3077}
3078
3079
88a95a11
FXC		 3080gfc_expr *
3081gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
3082{
3083 return simplify_shift (e, s, "ISHFT", false, 0);
3084}
3085
3086
3087gfc_expr *
3088gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
3089{
3090 return simplify_shift (e, s, "LSHIFT", false, 1);
3091}
3092
3093
3094gfc_expr *
3095gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
3096{
3097 return simplify_shift (e, s, "RSHIFT", true, -1);
3098}
3099
3100
3101gfc_expr *
3102gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
3103{
3104 return simplify_shift (e, s, "SHIFTA", true, -1);
3105}
3106
3107
3108gfc_expr *
3109gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
3110{
3111 return simplify_shift (e, s, "SHIFTL", false, 1);
3112}
3113
3114
3115gfc_expr *
3116gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
3117{
3118 return simplify_shift (e, s, "SHIFTR", false, -1);
3119}
3120
3121
6de9cd9a 3122gfc_expr *
edf1eac2 3123gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
6de9cd9a
DN		 3124{
3125 gfc_expr *result;
f1dcb9bf 3126 int shift, ashift, isize, ssize, delta, k;
6de9cd9a
DN		 3127 int i, *bits;
3128
3129 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3130 return NULL;
3131
58a9e3c4 3132 gfc_extract_int (s, &shift);
6de9cd9a 3133
e7a2d5fb 3134 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
f1dcb9bf 3135 isize = gfc_integer_kinds[k].bit_size;
6de9cd9a
DN		 3136
3137 if (sz != NULL)
3138 {
f1dcb9bf 3139 if (sz->expr_type != EXPR_CONSTANT)
edf1eac2 3140 return NULL;
f1dcb9bf 3141
58a9e3c4 3142 gfc_extract_int (sz, &ssize);
f1dcb9bf 3143
6de9cd9a
DN		 3144 }
3145 else
f1dcb9bf 3146 ssize = isize;
6de9cd9a
DN		 3147
3148 if (shift >= 0)
3149 ashift = shift;
3150 else
3151 ashift = -shift;
3152
f1dcb9bf 3153 if (ashift > ssize)
6de9cd9a 3154 {
58a9e3c4 3155 if (sz == NULL)
f1dcb9bf
BM		 3156 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3157 "BIT_SIZE of first argument at %L", &s->where);
6de9cd9a
DN		 3158 return &gfc_bad_expr;
3159 }
3160
b7e75771 3161 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6de9cd9a 3162
f1dcb9bf
BM		 3163 mpz_set (result->value.integer, e->value.integer);
3164
5d24a977 3165 if (shift == 0)
f1dcb9bf 3166 return result;
5d24a977 3167
f1dcb9bf 3168 convert_mpz_to_unsigned (result->value.integer, isize);
6de9cd9a 3169
ece3f663 3170 bits = XCNEWVEC (int, ssize);
f1dcb9bf
BM		 3171
3172 for (i = 0; i < ssize; i++)
6de9cd9a
DN		 3173 bits[i] = mpz_tstbit (e->value.integer, i);
3174
f1dcb9bf 3175 delta = ssize - ashift;
6de9cd9a 3176
5d24a977 3177 if (shift > 0)
6de9cd9a
DN		 3178 {
3179 for (i = 0; i < delta; i++)
3180 {
3181 if (bits[i] == 0)
3182 mpz_clrbit (result->value.integer, i + shift);
5d24a977 3183 else
6de9cd9a
DN		 3184 mpz_setbit (result->value.integer, i + shift);
3185 }
3186
f1dcb9bf 3187 for (i = delta; i < ssize; i++)
6de9cd9a
DN		 3188 {
3189 if (bits[i] == 0)
3190 mpz_clrbit (result->value.integer, i - delta);
5d24a977 3191 else
6de9cd9a
DN		 3192 mpz_setbit (result->value.integer, i - delta);
3193 }
6de9cd9a
DN		 3194 }
3195 else
3196 {
3197 for (i = 0; i < ashift; i++)
3198 {
3199 if (bits[i] == 0)
3200 mpz_clrbit (result->value.integer, i + delta);
5d24a977 3201 else
6de9cd9a
DN		 3202 mpz_setbit (result->value.integer, i + delta);
3203 }
3204
f1dcb9bf 3205 for (i = ashift; i < ssize; i++)
6de9cd9a
DN		 3206 {
3207 if (bits[i] == 0)
3208 mpz_clrbit (result->value.integer, i + shift);
5d24a977 3209 else
6de9cd9a
DN		 3210 mpz_setbit (result->value.integer, i + shift);
3211 }
6de9cd9a 3212 }
5d24a977 3213
f1dcb9bf 3214 convert_mpz_to_signed (result->value.integer, isize);
5d24a977 3215
cede9502 3216 free (bits);
5d24a977 3217 return result;
6de9cd9a
DN		 3218}
3219
3220
3221gfc_expr *
edf1eac2 3222gfc_simplify_kind (gfc_expr *e)
6de9cd9a 3223{
b7e75771 3224 return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
6de9cd9a
DN		 3225}
3226
3227
3228static gfc_expr *
5cda5098 3229simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
64f002ed 3230 gfc_array_spec *as, gfc_ref *ref, bool coarray)
6de9cd9a 3231{
9f1dce56 3232 gfc_expr *l, *u, *result;
5cda5098 3233 int k;
6de9cd9a 3234
69dcd06a 3235 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
8b704316 3236 gfc_default_integer_kind);
69dcd06a
DK		 3237 if (k == -1)
3238 return &gfc_bad_expr;
3239
3240 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
3241
3242 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3243 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3244 if (!coarray && array->expr_type != EXPR_VARIABLE)
3245 {
3246 if (upper)
3247 {
3248 gfc_expr* dim = result;
3249 mpz_set_si (dim->value.integer, d);
3250
3251 result = gfc_simplify_size (array, dim, kind);
3252 gfc_free_expr (dim);
3253 if (!result)
3254 goto returnNull;
3255 }
3256 else
3257 mpz_set_si (result->value.integer, 1);
3258
3259 goto done;
3260 }
3261
3262 /* Otherwise, we have a variable expression. */
3263 gcc_assert (array->expr_type == EXPR_VARIABLE);
3264 gcc_assert (as);
3265
524af0d6 3266 if (!gfc_resolve_array_spec (as, 0))
0423b64a
MM		 3267 return NULL;
3268
fc9f54d5 3269 /* The last dimension of an assumed-size array is special. */
64f002ed 3270 if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
155e5d5f
TB		 3271 || (coarray && d == as->rank + as->corank
3272 && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE)))
fc9f54d5
FXC		 3273 {
3274 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
69dcd06a
DK		 3275 {
3276 gfc_free_expr (result);
3277 return gfc_copy_expr (as->lower[d-1]);
3278 }
6de9cd9a 3279
69dcd06a
DK		 3280 goto returnNull;
3281 }
5cda5098 3282
b7e75771 3283 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
fc9f54d5 3284
543af7ab 3285 /* Then, we need to know the extent of the given dimension. */
64f002ed 3286 if (coarray || ref->u.ar.type == AR_FULL)
fc9f54d5 3287 {
543af7ab
TK		 3288 l = as->lower[d-1];
3289 u = as->upper[d-1];
3290
64f002ed
TB		 3291 if (l->expr_type != EXPR_CONSTANT || u == NULL
3292 || u->expr_type != EXPR_CONSTANT)
69dcd06a 3293 goto returnNull;
543af7ab
TK		 3294
3295 if (mpz_cmp (l->value.integer, u->value.integer) > 0)
3296 {
3297 /* Zero extent. */
3298 if (upper)
3299 mpz_set_si (result->value.integer, 0);
3300 else
3301 mpz_set_si (result->value.integer, 1);
3302 }
fc9f54d5 3303 else
543af7ab
TK		 3304 {
3305 /* Nonzero extent. */
3306 if (upper)
3307 mpz_set (result->value.integer, u->value.integer);
3308 else
3309 mpz_set (result->value.integer, l->value.integer);
3310 }
fc9f54d5
FXC		 3311 }
3312 else
3313 {
fc9f54d5 3314 if (upper)
543af7ab 3315 {
524af0d6 3316 if (!gfc_ref_dimen_size (&ref->u.ar, d - 1, &result->value.integer, NULL))
69dcd06a 3317 goto returnNull;
543af7ab 3318 }
fc9f54d5 3319 else
543af7ab 3320 mpz_set_si (result->value.integer, (long int) 1);
fc9f54d5
FXC		 3321 }
3322
69dcd06a 3323done:
fc9f54d5 3324 return range_check (result, upper ? "UBOUND" : "LBOUND");
69dcd06a
DK		 3325
3326returnNull:
3327 gfc_free_expr (result);
3328 return NULL;
fc9f54d5
FXC		 3329}
3330
3331
3332static gfc_expr *
5cda5098 3333simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
fc9f54d5
FXC		 3334{
3335 gfc_ref *ref;
3336 gfc_array_spec *as;
3337 int d;
3338
c49ea23d
PT		 3339 if (array->ts.type == BT_CLASS)
3340 return NULL;
3341
9f1dce56 3342 if (array->expr_type != EXPR_VARIABLE)
69dcd06a
DK		 3343 {
3344 as = NULL;
3345 ref = NULL;
3346 goto done;
3347 }
9f1dce56 3348
6de9cd9a
DN		 3349 /* Follow any component references. */
3350 as = array->symtree->n.sym->as;
2a4a7830
TS		 3351 for (ref = array->ref; ref; ref = ref->next)
3352 {
3353 switch (ref->type)
3354 {
3355 case REF_ARRAY:
3356 switch (ref->u.ar.type)
3357 {
3358 case AR_ELEMENT:
3359 as = NULL;
3360 continue;
3361
3362 case AR_FULL:
3363 /* We're done because 'as' has already been set in the
3364 previous iteration. */
9295d9ed 3365 if (!ref->next)
69dcd06a 3366 goto done;
9295d9ed
MM		 3367
3368 /* Fall through. */
2a4a7830 3369
2a4a7830
TS		 3370 case AR_UNKNOWN:
3371 return NULL;
543af7ab
TK		 3372
3373 case AR_SECTION:
3374 as = ref->u.ar.as;
3375 goto done;
2a4a7830
TS		 3376 }
3377
3378 gcc_unreachable ();
3379
3380 case REF_COMPONENT:
3381 as = ref->u.c.component->as;
3382 continue;
3383
3384 case REF_SUBSTRING:
3385 continue;
3386 }
3387 }
3388
3389 gcc_unreachable ();
3390
3391 done:
fc9f54d5 3392
c62c6622
TB		 3393 if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
3394 || as->type == AS_ASSUMED_RANK))
2a4a7830
TS		 3395 return NULL;
3396
fc9f54d5 3397 if (dim == NULL)
6de9cd9a 3398 {
fc9f54d5
FXC		 3399 /* Multi-dimensional bounds. */
3400 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3401 gfc_expr *e;
5cda5098 3402 int k;
6de9cd9a 3403
fc9f54d5 3404 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
69dcd06a 3405 if (upper && as && as->type == AS_ASSUMED_SIZE)
fc9f54d5
FXC		 3406 {
3407 /* An error message will be emitted in
3408 check_assumed_size_reference (resolve.c). */
3409 return &gfc_bad_expr;
3410 }
2a4a7830 3411
fc9f54d5
FXC		 3412 /* Simplify the bounds for each dimension. */
3413 for (d = 0; d < array->rank; d++)
3414 {
64f002ed
TB		 3415 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
3416 false);
fc9f54d5
FXC		 3417 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3418 {
3419 int j;
9f1dce56 3420
fc9f54d5
FXC		 3421 for (j = 0; j < d; j++)
3422 gfc_free_expr (bounds[j]);
3423 return bounds[d];
3424 }
3425 }
2a4a7830 3426
fc9f54d5 3427 /* Allocate the result expression. */
5cda5098 3428 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
b7e75771 3429 gfc_default_integer_kind);
5cda5098 3430 if (k == -1)
b7e75771
JD		 3431 return &gfc_bad_expr;
3432
3433 e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
fc9f54d5
FXC		 3434
3435 /* The result is a rank 1 array; its size is the rank of the first
3436 argument to {L,U}BOUND. */
3437 e->rank = 1;
3438 e->shape = gfc_get_shape (1);
3439 mpz_init_set_ui (e->shape[0], array->rank);
3440
3441 /* Create the constructor for this array. */
fc9f54d5 3442 for (d = 0; d < array->rank; d++)
b7e75771
JD		 3443 gfc_constructor_append_expr (&e->value.constructor,
3444 bounds[d], &e->where);
fc9f54d5
FXC		 3445
3446 return e;
9f1dce56
FXC		 3447 }
3448 else
3449 {
fc9f54d5
FXC		 3450 /* A DIM argument is specified. */
3451 if (dim->expr_type != EXPR_CONSTANT)
3452 return NULL;
9f1dce56 3453
fc9f54d5
FXC		 3454 d = mpz_get_si (dim->value.integer);
3455
c62c6622 3456 if ((d < 1 || d > array->rank)
69dcd06a 3457 || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
fc9f54d5
FXC		 3458 {
3459 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3460 return &gfc_bad_expr;
3461 }
3462
c62c6622
TB		 3463 if (as && as->type == AS_ASSUMED_RANK)
3464 return NULL;
3465
64f002ed
TB		 3466 return simplify_bound_dim (array, kind, d, upper, as, ref, false);
3467 }
3468}
3469
3470
3471static gfc_expr *
3472simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3473{
3474 gfc_ref *ref;
3475 gfc_array_spec *as;
3476 int d;
3477
3478 if (array->expr_type != EXPR_VARIABLE)
3479 return NULL;
3480
3481 /* Follow any component references. */
c49ea23d
PT		 3482 as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
3483 ? array->ts.u.derived->components->as
3484 : array->symtree->n.sym->as;
64f002ed
TB		 3485 for (ref = array->ref; ref; ref = ref->next)
3486 {
3487 switch (ref->type)
3488 {
3489 case REF_ARRAY:
3490 switch (ref->u.ar.type)
3491 {
3492 case AR_ELEMENT:
dbeebc56 3493 if (ref->u.ar.as->corank > 0)
a10da381 3494 {
dbeebc56 3495 gcc_assert (as == ref->u.ar.as);
a10da381
TB		 3496 goto done;
3497 }
64f002ed
TB		 3498 as = NULL;
3499 continue;
3500
3501 case AR_FULL:
3502 /* We're done because 'as' has already been set in the
3503 previous iteration. */
3504 if (!ref->next)
3505 goto done;
3506
3507 /* Fall through. */
3508
3509 case AR_UNKNOWN:
3510 return NULL;
3511
3512 case AR_SECTION:
3513 as = ref->u.ar.as;
3514 goto done;
3515 }
3516
3517 gcc_unreachable ();
3518
3519 case REF_COMPONENT:
3520 as = ref->u.c.component->as;
3521 continue;
3522
3523 case REF_SUBSTRING:
3524 continue;
3525 }
3526 }
3527
c49ea23d
PT		 3528 if (!as)
3529 gcc_unreachable ();
64f002ed
TB		 3530
3531 done:
3532
c49ea23d 3533 if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
64f002ed
TB		 3534 return NULL;
3535
3536 if (dim == NULL)
3537 {
3538 /* Multi-dimensional cobounds. */
3539 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3540 gfc_expr *e;
3541 int k;
3542
3543 /* Simplify the cobounds for each dimension. */
3544 for (d = 0; d < as->corank; d++)
3545 {
c49ea23d 3546 bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
64f002ed
TB		 3547 upper, as, ref, true);
3548 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3549 {
3550 int j;
3551
3552 for (j = 0; j < d; j++)
3553 gfc_free_expr (bounds[j]);
3554 return bounds[d];
3555 }
3556 }
3557
3558 /* Allocate the result expression. */
3559 e = gfc_get_expr ();
3560 e->where = array->where;
3561 e->expr_type = EXPR_ARRAY;
3562 e->ts.type = BT_INTEGER;
3563 k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
8b704316 3564 gfc_default_integer_kind);
64f002ed
TB		 3565 if (k == -1)
3566 {
3567 gfc_free_expr (e);
3568 return &gfc_bad_expr;
3569 }
3570 e->ts.kind = k;
3571
3572 /* The result is a rank 1 array; its size is the rank of the first
3573 argument to {L,U}COBOUND. */
3574 e->rank = 1;
3575 e->shape = gfc_get_shape (1);
3576 mpz_init_set_ui (e->shape[0], as->corank);
3577
3578 /* Create the constructor for this array. */
3579 for (d = 0; d < as->corank; d++)
3580 gfc_constructor_append_expr (&e->value.constructor,
3581 bounds[d], &e->where);
3582 return e;
3583 }
3584 else
3585 {
3586 /* A DIM argument is specified. */
3587 if (dim->expr_type != EXPR_CONSTANT)
3588 return NULL;
3589
3590 d = mpz_get_si (dim->value.integer);
3591
3592 if (d < 1 || d > as->corank)
3593 {
3594 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3595 return &gfc_bad_expr;
3596 }
3597
c49ea23d 3598 return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
fc9f54d5 3599 }
6de9cd9a
DN		 3600}
3601
3602
3603gfc_expr *
5cda5098 3604gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6de9cd9a 3605{
5cda5098 3606 return simplify_bound (array, dim, kind, 0);
6de9cd9a
DN		 3607}
3608
3609
64f002ed
TB		 3610gfc_expr *
3611gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3612{
a3935ffc 3613 return simplify_cobound (array, dim, kind, 0);
64f002ed
TB		 3614}
3615
414f00e9
SB		 3616gfc_expr *
3617gfc_simplify_leadz (gfc_expr *e)
3618{
414f00e9
SB		 3619 unsigned long lz, bs;
3620 int i;
3621
3622 if (e->expr_type != EXPR_CONSTANT)
3623 return NULL;
3624
3625 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3626 bs = gfc_integer_kinds[i].bit_size;
3627 if (mpz_cmp_si (e->value.integer, 0) == 0)
3628 lz = bs;
0a05c536
FXC		 3629 else if (mpz_cmp_si (e->value.integer, 0) < 0)
3630 lz = 0;
414f00e9
SB		 3631 else
3632 lz = bs - mpz_sizeinbase (e->value.integer, 2);
3633
b7e75771 3634 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
414f00e9
SB		 3635}
3636
3637
6de9cd9a 3638gfc_expr *
5cda5098 3639gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
6de9cd9a
DN		 3640{
3641 gfc_expr *result;
5cda5098
FXC		 3642 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
3643
3644 if (k == -1)
3645 return &gfc_bad_expr;
6de9cd9a 3646
49914d03
FXC		 3647 if (e->expr_type == EXPR_CONSTANT)
3648 {
b7e75771 3649 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
49914d03 3650 mpz_set_si (result->value.integer, e->value.character.length);
b7e75771 3651 return range_check (result, "LEN");
49914d03 3652 }
b7e75771
JD		 3653 else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3654 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3655 && e->ts.u.cl->length->ts.type == BT_INTEGER)
49914d03 3656 {
b7e75771 3657 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
bc21d315 3658 mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
b7e75771 3659 return range_check (result, "LEN");
49914d03 3660 }
b7e75771
JD		 3661 else
3662 return NULL;
6de9cd9a
DN		 3663}
3664
3665
3666gfc_expr *
5cda5098 3667gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
6de9cd9a
DN		 3668{
3669 gfc_expr *result;
b7e75771 3670 int count, len, i;
5cda5098
FXC		 3671 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3672
3673 if (k == -1)
3674 return &gfc_bad_expr;
6de9cd9a
DN		 3675
3676 if (e->expr_type != EXPR_CONSTANT)
3677 return NULL;
3678
6de9cd9a 3679 len = e->value.character.length;
6de9cd9a
DN		 3680 for (count = 0, i = 1; i <= len; i++)
3681 if (e->value.character.string[len - i] == ' ')
3682 count++;
3683 else
3684 break;
3685
b7e75771 3686 result = gfc_get_int_expr (k, &e->where, len - count);
6de9cd9a
DN		 3687 return range_check (result, "LEN_TRIM");
3688}
3689
75be5dc0 3690gfc_expr *
b7e75771 3691gfc_simplify_lgamma (gfc_expr *x)
75be5dc0 3692{
75be5dc0 3693 gfc_expr *result;
5b550abd 3694 int sg;
75be5dc0
TB		 3695
3696 if (x->expr_type != EXPR_CONSTANT)
3697 return NULL;
3698
b7e75771 3699 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5b550abd 3700 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
75be5dc0
TB		 3701
3702 return range_check (result, "LGAMMA");
75be5dc0
TB		 3703}
3704
6de9cd9a
DN		 3705
3706gfc_expr *
edf1eac2 3707gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
6de9cd9a 3708{
6de9cd9a
DN		 3709 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3710 return NULL;
3711
b7e75771
JD		 3712 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3713 gfc_compare_string (a, b) >= 0);
6de9cd9a
DN		 3714}
3715
3716
3717gfc_expr *
edf1eac2 3718gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
6de9cd9a 3719{
6de9cd9a
DN		 3720 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3721 return NULL;
3722
b7e75771
JD		 3723 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3724 gfc_compare_string (a, b) > 0);
6de9cd9a
DN		 3725}
3726
3727
3728gfc_expr *
edf1eac2 3729gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
6de9cd9a 3730{
6de9cd9a
DN		 3731 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3732 return NULL;
3733
b7e75771
JD		 3734 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3735 gfc_compare_string (a, b) <= 0);
6de9cd9a
DN		 3736}
3737
3738
3739gfc_expr *
edf1eac2 3740gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
6de9cd9a 3741{
6de9cd9a
DN		 3742 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
3743 return NULL;
3744
b7e75771
JD		 3745 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3746 gfc_compare_string (a, b) < 0);
6de9cd9a
DN		 3747}
3748
3749
3750gfc_expr *
edf1eac2 3751gfc_simplify_log (gfc_expr *x)
6de9cd9a
DN		 3752{
3753 gfc_expr *result;
6de9cd9a
DN		 3754
3755 if (x->expr_type != EXPR_CONSTANT)
3756 return NULL;
3757
b7e75771 3758 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
f8e566e5 3759
6de9cd9a
DN		 3760 switch (x->ts.type)
3761 {
3762 case BT_REAL:
03ddaf35 3763 if (mpfr_sgn (x->value.real) <= 0)
6de9cd9a 3764 {
edf1eac2
SK		 3765 gfc_error ("Argument of LOG at %L cannot be less than or equal "
3766 "to zero", &x->where);
6de9cd9a
DN		 3767 gfc_free_expr (result);
3768 return &gfc_bad_expr;
3769 }
3770
edf1eac2 3771 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
6de9cd9a
DN		 3772 break;
3773
3774 case BT_COMPLEX:
eb6f9a86
KG		 3775 if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
3776 && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
6de9cd9a
DN		 3777 {
3778 gfc_error ("Complex argument of LOG at %L cannot be zero",
3779 &x->where);
3780 gfc_free_expr (result);
3781 return &gfc_bad_expr;
3782 }
3783
7306494a 3784 gfc_set_model_kind (x->ts.kind);
eb6f9a86 3785 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6de9cd9a
DN		 3786 break;
3787
3788 default:
3789 gfc_internal_error ("gfc_simplify_log: bad type");
3790 }
3791
3792 return range_check (result, "LOG");
3793}
3794
3795
3796gfc_expr *
edf1eac2 3797gfc_simplify_log10 (gfc_expr *x)
6de9cd9a
DN		 3798{
3799 gfc_expr *result;
3800
3801 if (x->expr_type != EXPR_CONSTANT)
3802 return NULL;
3803
03ddaf35 3804 if (mpfr_sgn (x->value.real) <= 0)
6de9cd9a 3805 {
edf1eac2
SK		 3806 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
3807 "to zero", &x->where);
6de9cd9a
DN		 3808 return &gfc_bad_expr;
3809 }
3810
b7e75771 3811 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
f8e566e5 3812 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
6de9cd9a
DN		 3813
3814 return range_check (result, "LOG10");
3815}
3816
3817
3818gfc_expr *
edf1eac2 3819gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
6de9cd9a 3820{
6de9cd9a
DN		 3821 int kind;
3822
9d64df18 3823 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
6de9cd9a
DN		 3824 if (kind < 0)
3825 return &gfc_bad_expr;
3826
3827 if (e->expr_type != EXPR_CONSTANT)
3828 return NULL;
3829
b7e75771 3830 return gfc_get_logical_expr (kind, &e->where, e->value.logical);
6de9cd9a
DN		 3831}
3832
3833
8ec259c1
DF		 3834gfc_expr*
3835gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
3836{
3837 gfc_expr *result;
b7e75771
JD		 3838 int row, result_rows, col, result_columns;
3839 int stride_a, offset_a, stride_b, offset_b;
8ec259c1
DF		 3840
3841 if (!is_constant_array_expr (matrix_a)
3842 || !is_constant_array_expr (matrix_b))
3843 return NULL;
3844
3845 gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
b7e75771
JD		 3846 result = gfc_get_array_expr (matrix_a->ts.type,
3847 matrix_a->ts.kind,
3848 &matrix_a->where);
8ec259c1
DF		 3849
3850 if (matrix_a->rank == 1 && matrix_b->rank == 2)
3851 {
3852 result_rows = 1;
711db0a6 3853 result_columns = mpz_get_si (matrix_b->shape[1]);
8ec259c1
DF		 3854 stride_a = 1;
3855 stride_b = mpz_get_si (matrix_b->shape[0]);
3856
3857 result->rank = 1;
3858 result->shape = gfc_get_shape (result->rank);
3859 mpz_init_set_si (result->shape[0], result_columns);
3860 }
3861 else if (matrix_a->rank == 2 && matrix_b->rank == 1)
3862 {
711db0a6 3863 result_rows = mpz_get_si (matrix_a->shape[0]);
8ec259c1
DF		 3864 result_columns = 1;
3865 stride_a = mpz_get_si (matrix_a->shape[0]);
3866 stride_b = 1;
3867
3868 result->rank = 1;
3869 result->shape = gfc_get_shape (result->rank);
3870 mpz_init_set_si (result->shape[0], result_rows);
3871 }
3872 else if (matrix_a->rank == 2 && matrix_b->rank == 2)
3873 {
3874 result_rows = mpz_get_si (matrix_a->shape[0]);
3875 result_columns = mpz_get_si (matrix_b->shape[1]);
711db0a6 3876 stride_a = mpz_get_si (matrix_a->shape[0]);
8ec259c1
DF		 3877 stride_b = mpz_get_si (matrix_b->shape[0]);
3878
3879 result->rank = 2;
3880 result->shape = gfc_get_shape (result->rank);
3881 mpz_init_set_si (result->shape[0], result_rows);
3882 mpz_init_set_si (result->shape[1], result_columns);
3883 }
3884 else
3885 gcc_unreachable();
3886
b7e75771 3887 offset_a = offset_b = 0;
8ec259c1
DF		 3888 for (col = 0; col < result_columns; ++col)
3889 {
b7e75771 3890 offset_a = 0;
8ec259c1
DF		 3891
3892 for (row = 0; row < result_rows; ++row)
3893 {
b7e75771
JD		 3894 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
3895 matrix_b, 1, offset_b);
3896 gfc_constructor_append_expr (&result->value.constructor,
3897 e, NULL);
8ec259c1 3898
b7e75771
JD		 3899 offset_a += 1;
3900 }
8ec259c1 3901
b7e75771 3902 offset_b += stride_b;
8ec259c1
DF		 3903 }
3904
3905 return result;
3906}
3907
3908
88a95a11
FXC		 3909gfc_expr *
3910gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
3911{
3912 gfc_expr *result;
3913 int kind, arg, k;
3914 const char *s;
3915
3916 if (i->expr_type != EXPR_CONSTANT)
3917 return NULL;
8b704316 3918
88a95a11
FXC		 3919 kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
3920 if (kind == -1)
3921 return &gfc_bad_expr;
3922 k = gfc_validate_kind (BT_INTEGER, kind, false);
3923
3924 s = gfc_extract_int (i, &arg);
3925 gcc_assert (!s);
3926
3927 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
3928
3929 /* MASKR(n) = 2^n - 1 */
3930 mpz_set_ui (result->value.integer, 1);
3931 mpz_mul_2exp (result->value.integer, result->value.integer, arg);
3932 mpz_sub_ui (result->value.integer, result->value.integer, 1);
3933
3934 convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
3935
3936 return result;
3937}
3938
3939
3940gfc_expr *
3941gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
3942{
3943 gfc_expr *result;
3944 int kind, arg, k;
3945 const char *s;
3946 mpz_t z;
3947
3948 if (i->expr_type != EXPR_CONSTANT)
3949 return NULL;
8b704316 3950
88a95a11
FXC		 3951 kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
3952 if (kind == -1)
3953 return &gfc_bad_expr;
3954 k = gfc_validate_kind (BT_INTEGER, kind, false);
3955
3956 s = gfc_extract_int (i, &arg);
3957 gcc_assert (!s);
3958
3959 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
3960
3961 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
3962 mpz_init_set_ui (z, 1);
3963 mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
3964 mpz_set_ui (result->value.integer, 1);
3965 mpz_mul_2exp (result->value.integer, result->value.integer,
3966 gfc_integer_kinds[k].bit_size - arg);
3967 mpz_sub (result->value.integer, z, result->value.integer);
3968 mpz_clear (z);
3969
3970 convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
3971
3972 return result;
3973}
3974
3975
8f2b565d
DF		 3976gfc_expr *
3977gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
3978{
03580130
TB		 3979 gfc_expr * result;
3980 gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
3981
3982 if (mask->expr_type == EXPR_CONSTANT)
3983 return gfc_get_parentheses (gfc_copy_expr (mask->value.logical
3984 ? tsource : fsource));
3985
3986 if (!mask->rank || !is_constant_array_expr (mask)
3987 || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
8f2b565d
DF		 3988 return NULL;
3989
03580130
TB		 3990 result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
3991 &tsource->where);
3992 if (tsource->ts.type == BT_DERIVED)
3993 result->ts.u.derived = tsource->ts.u.derived;
3994 else if (tsource->ts.type == BT_CHARACTER)
3995 result->ts.u.cl = tsource->ts.u.cl;
3996
3997 tsource_ctor = gfc_constructor_first (tsource->value.constructor);
3998 fsource_ctor = gfc_constructor_first (fsource->value.constructor);
3999 mask_ctor = gfc_constructor_first (mask->value.constructor);
4000
4001 while (mask_ctor)
4002 {
4003 if (mask_ctor->expr->value.logical)
4004 gfc_constructor_append_expr (&result->value.constructor,
4005 gfc_copy_expr (tsource_ctor->expr),
4006 NULL);
4007 else
4008 gfc_constructor_append_expr (&result->value.constructor,
4009 gfc_copy_expr (fsource_ctor->expr),
4010 NULL);
4011 tsource_ctor = gfc_constructor_next (tsource_ctor);
4012 fsource_ctor = gfc_constructor_next (fsource_ctor);
4013 mask_ctor = gfc_constructor_next (mask_ctor);
4014 }
4015
4016 result->shape = gfc_get_shape (1);
4017 gfc_array_size (result, &result->shape[0]);
4018
4019 return result;
8f2b565d
DF		 4020}
4021
4022
88a95a11
FXC		 4023gfc_expr *
4024gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
4025{
4026 mpz_t arg1, arg2, mask;
4027 gfc_expr *result;
4028
4029 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
4030 || mask_expr->expr_type != EXPR_CONSTANT)
4031 return NULL;
4032
4033 result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
4034
4035 /* Convert all argument to unsigned. */
4036 mpz_init_set (arg1, i->value.integer);
4037 mpz_init_set (arg2, j->value.integer);
4038 mpz_init_set (mask, mask_expr->value.integer);
4039
4040 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4041 mpz_and (arg1, arg1, mask);
4042 mpz_com (mask, mask);
4043 mpz_and (arg2, arg2, mask);
4044 mpz_ior (result->value.integer, arg1, arg2);
4045
4046 mpz_clear (arg1);
4047 mpz_clear (arg2);
4048 mpz_clear (mask);
4049
4050 return result;
4051}
4052
4053
4054/* Selects between current value and extremum for simplify_min_max
5a0193ee
PT		 4055 and simplify_minval_maxval. */
4056static void
4057min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
4058{
4059 switch (arg->ts.type)
4060 {
4061 case BT_INTEGER:
4062 if (mpz_cmp (arg->value.integer,
4063 extremum->value.integer) * sign > 0)
4064 mpz_set (extremum->value.integer, arg->value.integer);
4065 break;
4066
4067 case BT_REAL:
4068 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4069 if (sign > 0)
4070 mpfr_max (extremum->value.real, extremum->value.real,
4071 arg->value.real, GFC_RND_MODE);
4072 else
4073 mpfr_min (extremum->value.real, extremum->value.real,
4074 arg->value.real, GFC_RND_MODE);
4075 break;
4076
4077 case BT_CHARACTER:
4078#define LENGTH(x) ((x)->value.character.length)
4079#define STRING(x) ((x)->value.character.string)
524af0d6 4080 if (LENGTH (extremum) < LENGTH(arg))
5a0193ee
PT		 4081 {
4082 gfc_char_t *tmp = STRING(extremum);
4083
4084 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
4085 memcpy (STRING(extremum), tmp,
4086 LENGTH(extremum) * sizeof (gfc_char_t));
4087 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
4088 LENGTH(arg) - LENGTH(extremum));
4089 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
4090 LENGTH(extremum) = LENGTH(arg);
cede9502 4091 free (tmp);
5a0193ee
PT		 4092 }
4093
4094 if (gfc_compare_string (arg, extremum) * sign > 0)
4095 {
cede9502 4096 free (STRING(extremum));
5a0193ee
PT		 4097 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
4098 memcpy (STRING(extremum), STRING(arg),
4099 LENGTH(arg) * sizeof (gfc_char_t));
4100 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
4101 LENGTH(extremum) - LENGTH(arg));
4102 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
4103 }
4104#undef LENGTH
4105#undef STRING
4106 break;
8b704316 4107
5a0193ee
PT		 4108 default:
4109 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4110 }
4111}
4112
4113
6de9cd9a
DN		 4114/* This function is special since MAX() can take any number of
4115 arguments. The simplified expression is a rewritten version of the
4116 argument list containing at most one constant element. Other
4117 constant elements are deleted. Because the argument list has
4118 already been checked, this function always succeeds. sign is 1 for
4119 MAX(), -1 for MIN(). */
4120
4121static gfc_expr *
edf1eac2 4122simplify_min_max (gfc_expr *expr, int sign)
6de9cd9a
DN		 4123{
4124 gfc_actual_arglist *arg, *last, *extremum;
4125 gfc_intrinsic_sym * specific;
4126
4127 last = NULL;
4128 extremum = NULL;
4129 specific = expr->value.function.isym;
4130
4131 arg = expr->value.function.actual;
4132
4133 for (; arg; last = arg, arg = arg->next)
4134 {
4135 if (arg->expr->expr_type != EXPR_CONSTANT)
4136 continue;
4137
4138 if (extremum == NULL)
4139 {
4140 extremum = arg;
4141 continue;
4142 }
4143
5a0193ee 4144 min_max_choose (arg->expr, extremum->expr, sign);
6de9cd9a
DN		 4145
4146 /* Delete the extra constant argument. */
99c25a87 4147 last->next = arg->next;
6de9cd9a
DN		 4148
4149 arg->next = NULL;
4150 gfc_free_actual_arglist (arg);
4151 arg = last;
4152 }
4153
4154 /* If there is one value left, replace the function call with the
4155 expression. */
4156 if (expr->value.function.actual->next != NULL)
4157 return NULL;
4158
4159 /* Convert to the correct type and kind. */
8b704316 4160 if (expr->ts.type != BT_UNKNOWN)
6de9cd9a
DN		 4161 return gfc_convert_constant (expr->value.function.actual->expr,
4162 expr->ts.type, expr->ts.kind);
4163
8b704316 4164 if (specific->ts.type != BT_UNKNOWN)
6de9cd9a 4165 return gfc_convert_constant (expr->value.function.actual->expr,
8b704316
PT		 4166 specific->ts.type, specific->ts.kind);
4167
6de9cd9a
DN		 4168 return gfc_copy_expr (expr->value.function.actual->expr);
4169}
4170
4171
4172gfc_expr *
edf1eac2 4173gfc_simplify_min (gfc_expr *e)
6de9cd9a 4174{
6de9cd9a
DN		 4175 return simplify_min_max (e, -1);
4176}
4177
4178
4179gfc_expr *
edf1eac2 4180gfc_simplify_max (gfc_expr *e)
6de9cd9a 4181{
6de9cd9a
DN		 4182 return simplify_min_max (e, 1);
4183}
4184
4185
5a0193ee
PT		 4186/* This is a simplified version of simplify_min_max to provide
4187 simplification of minval and maxval for a vector. */
4188
4189static gfc_expr *
4190simplify_minval_maxval (gfc_expr *expr, int sign)
4191{
b7e75771 4192 gfc_constructor *c, *extremum;
5a0193ee
PT		 4193 gfc_intrinsic_sym * specific;
4194
4195 extremum = NULL;
4196 specific = expr->value.function.isym;
4197
b7e75771
JD		 4198 for (c = gfc_constructor_first (expr->value.constructor);
4199 c; c = gfc_constructor_next (c))
5a0193ee 4200 {
b7e75771 4201 if (c->expr->expr_type != EXPR_CONSTANT)
5a0193ee
PT		 4202 return NULL;
4203
4204 if (extremum == NULL)
4205 {
b7e75771 4206 extremum = c;
5a0193ee
PT		 4207 continue;
4208 }
4209
b7e75771 4210 min_max_choose (c->expr, extremum->expr, sign);
5a0193ee
PT		 4211 }
4212
4213 if (extremum == NULL)
4214 return NULL;
4215
4216 /* Convert to the correct type and kind. */
8b704316 4217 if (expr->ts.type != BT_UNKNOWN)
5a0193ee
PT		 4218 return gfc_convert_constant (extremum->expr,
4219 expr->ts.type, expr->ts.kind);
4220
8b704316 4221 if (specific->ts.type != BT_UNKNOWN)
5a0193ee 4222 return gfc_convert_constant (extremum->expr,
8b704316
PT		 4223 specific->ts.type, specific->ts.kind);
4224
5a0193ee
PT		 4225 return gfc_copy_expr (extremum->expr);
4226}
4227
4228
4229gfc_expr *
4230gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4231{
4232 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4233 return NULL;
b7e75771 4234
5a0193ee
PT		 4235 return simplify_minval_maxval (array, -1);
4236}
4237
4238
4239gfc_expr *
4240gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4241{
4242 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4243 return NULL;
b7e75771 4244
5a0193ee
PT		 4245 return simplify_minval_maxval (array, 1);
4246}
4247
4248
6de9cd9a 4249gfc_expr *
edf1eac2 4250gfc_simplify_maxexponent (gfc_expr *x)
6de9cd9a 4251{
b7e75771
JD		 4252 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4253 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4254 gfc_real_kinds[i].max_exponent);
6de9cd9a
DN		 4255}
4256
4257
4258gfc_expr *
edf1eac2 4259gfc_simplify_minexponent (gfc_expr *x)
6de9cd9a 4260{
b7e75771
JD		 4261 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4262 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4263 gfc_real_kinds[i].min_exponent);
6de9cd9a
DN		 4264}
4265
4266
4267gfc_expr *
edf1eac2 4268gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
6de9cd9a
DN		 4269{
4270 gfc_expr *result;
991bb832 4271 int kind;
6de9cd9a
DN		 4272
4273 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4274 return NULL;
4275
991bb832 4276 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
b7e75771 4277 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6de9cd9a
DN		 4278
4279 switch (a->ts.type)
4280 {
b7e75771
JD		 4281 case BT_INTEGER:
4282 if (mpz_cmp_ui (p->value.integer, 0) == 0)
4283 {
4284 /* Result is processor-dependent. */
4285 gfc_error ("Second argument MOD at %L is zero", &a->where);
4286 gfc_free_expr (result);
4287 return &gfc_bad_expr;
4288 }
4289 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
4290 break;
6de9cd9a 4291
b7e75771
JD		 4292 case BT_REAL:
4293 if (mpfr_cmp_ui (p->value.real, 0) == 0)
4294 {
4295 /* Result is processor-dependent. */
4296 gfc_error ("Second argument of MOD at %L is zero", &p->where);
4297 gfc_free_expr (result);
4298 return &gfc_bad_expr;
4299 }
6de9cd9a 4300
b7e75771 4301 gfc_set_model_kind (kind);
8b704316 4302 mpfr_fmod (result->value.real, a->value.real, p->value.real,
4ecad771 4303 GFC_RND_MODE);
b7e75771 4304 break;
6de9cd9a 4305
b7e75771
JD		 4306 default:
4307 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6de9cd9a
DN		 4308 }
4309
4310 return range_check (result, "MOD");
4311}
4312
4313
4314gfc_expr *
edf1eac2 4315gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
6de9cd9a
DN		 4316{
4317 gfc_expr *result;
991bb832 4318 int kind;
6de9cd9a
DN		 4319
4320 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4321 return NULL;
4322
991bb832 4323 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
b7e75771 4324 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6de9cd9a
DN		 4325
4326 switch (a->ts.type)
4327 {
b7e75771
JD		 4328 case BT_INTEGER:
4329 if (mpz_cmp_ui (p->value.integer, 0) == 0)
4330 {
4331 /* Result is processor-dependent. This processor just opts
4332 to not handle it at all. */
4333 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
4334 gfc_free_expr (result);
4335 return &gfc_bad_expr;
4336 }
4337 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
6de9cd9a 4338
b7e75771 4339 break;
6de9cd9a 4340
b7e75771
JD		 4341 case BT_REAL:
4342 if (mpfr_cmp_ui (p->value.real, 0) == 0)
4343 {
4344 /* Result is processor-dependent. */
4345 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
4346 gfc_free_expr (result);
4347 return &gfc_bad_expr;
4348 }
6de9cd9a 4349
b7e75771 4350 gfc_set_model_kind (kind);
8b704316 4351 mpfr_fmod (result->value.real, a->value.real, p->value.real,
4ecad771
JB		 4352 GFC_RND_MODE);
4353 if (mpfr_cmp_ui (result->value.real, 0) != 0)
4354 {
4355 if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
4356 mpfr_add (result->value.real, result->value.real, p->value.real,
4357 GFC_RND_MODE);
4358 }
4359 else
8b704316 4360 mpfr_copysign (result->value.real, result->value.real,
4ecad771 4361 p->value.real, GFC_RND_MODE);
b7e75771 4362 break;
6de9cd9a 4363
b7e75771
JD		 4364 default:
4365 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6de9cd9a
DN		 4366 }
4367
4368 return range_check (result, "MODULO");
4369}
4370
4371
4372/* Exists for the sole purpose of consistency with other intrinsics. */
4373gfc_expr *
edf1eac2
SK		 4374gfc_simplify_mvbits (gfc_expr *f ATTRIBUTE_UNUSED,
4375 gfc_expr *fp ATTRIBUTE_UNUSED,
4376 gfc_expr *l ATTRIBUTE_UNUSED,
4377 gfc_expr *to ATTRIBUTE_UNUSED,
4378 gfc_expr *tp ATTRIBUTE_UNUSED)
6de9cd9a
DN		 4379{
4380 return NULL;
4381}
4382
4383
4384gfc_expr *
edf1eac2 4385gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
6de9cd9a
DN		 4386{
4387 gfc_expr *result;
b6f63e89
TB		 4388 mp_exp_t emin, emax;
4389 int kind;
6de9cd9a 4390
9f32d037 4391 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
6de9cd9a
DN		 4392 return NULL;
4393
e48d66a9
SK		 4394 result = gfc_copy_expr (x);
4395
b6f63e89
TB		 4396 /* Save current values of emin and emax. */
4397 emin = mpfr_get_emin ();
4398 emax = mpfr_get_emax ();
4399
4400 /* Set emin and emax for the current model number. */
4401 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
4402 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
4403 mpfr_get_prec(result->value.real) + 1);
4404 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
ca430085 4405 mpfr_check_range (result->value.real, 0, GMP_RNDU);
b6f63e89
TB		 4406
4407 if (mpfr_sgn (s->value.real) > 0)
4408 {
4409 mpfr_nextabove (result->value.real);
4410 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
4411 }
4412 else
4413 {
4414 mpfr_nextbelow (result->value.real);
4415 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
4416 }
4417
4418 mpfr_set_emin (emin);
4419 mpfr_set_emax (emax);
6de9cd9a 4420
b6f63e89
TB		 4421 /* Only NaN can occur. Do not use range check as it gives an
4422 error for denormal numbers. */
4423 if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
4424 {
4425 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
d93712d9 4426 gfc_free_expr (result);
b6f63e89
TB		 4427 return &gfc_bad_expr;
4428 }
4429
4430 return result;
6de9cd9a
DN		 4431}
4432
4433
4434static gfc_expr *
edf1eac2 4435simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
6de9cd9a 4436{
8e1fa5d6
SK		 4437 gfc_expr *itrunc, *result;
4438 int kind;
6de9cd9a 4439
9d64df18 4440 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
6de9cd9a
DN		 4441 if (kind == -1)
4442 return &gfc_bad_expr;
4443
4444 if (e->expr_type != EXPR_CONSTANT)
4445 return NULL;
4446
6de9cd9a 4447 itrunc = gfc_copy_expr (e);
edf1eac2 4448 mpfr_round (itrunc->value.real, e->value.real);
6de9cd9a 4449
b7e75771 4450 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
7278e4dc 4451 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
6de9cd9a
DN		 4452
4453 gfc_free_expr (itrunc);
6de9cd9a
DN		 4454
4455 return range_check (result, name);
4456}
4457
4458
bec93d79 4459gfc_expr *
edf1eac2 4460gfc_simplify_new_line (gfc_expr *e)
bec93d79
TB		 4461{
4462 gfc_expr *result;
4463
b7e75771 4464 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
bec93d79 4465 result->value.character.string[0] = '\n';
b7e75771 4466
bec93d79
TB		 4467 return result;
4468}
4469
4470
6de9cd9a 4471gfc_expr *
edf1eac2 4472gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
6de9cd9a 4473{
6de9cd9a
DN		 4474 return simplify_nint ("NINT", e, k);
4475}
4476
4477
4478gfc_expr *
edf1eac2 4479gfc_simplify_idnint (gfc_expr *e)
6de9cd9a 4480{
6de9cd9a
DN		 4481 return simplify_nint ("IDNINT", e, NULL);
4482}
4483
4484
0cd0559e
TB		 4485static gfc_expr *
4486add_squared (gfc_expr *result, gfc_expr *e)
4487{
4488 mpfr_t tmp;
4489
4490 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4491 gcc_assert (result->ts.type == BT_REAL
4492 && result->expr_type == EXPR_CONSTANT);
4493
4494 gfc_set_model_kind (result->ts.kind);
4495 mpfr_init (tmp);
4496 mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
4497 mpfr_add (result->value.real, result->value.real, tmp,
4498 GFC_RND_MODE);
4499 mpfr_clear (tmp);
4500
4501 return result;
4502}
4503
4504
4505static gfc_expr *
4506do_sqrt (gfc_expr *result, gfc_expr *e)
4507{
4508 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4509 gcc_assert (result->ts.type == BT_REAL
4510 && result->expr_type == EXPR_CONSTANT);
4511
4512 mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
4513 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4514 return result;
4515}
4516
4517
4518gfc_expr *
4519gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
4520{
4521 gfc_expr *result;
4522
4523 if (!is_constant_array_expr (e)
4524 || (dim != NULL && !gfc_is_constant_expr (dim)))
4525 return NULL;
4526
4527 result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
4528 init_result_expr (result, 0, NULL);
4529
4530 if (!dim || e->rank == 1)
4531 {
4532 result = simplify_transformation_to_scalar (result, e, NULL,
4533 add_squared);
4534 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4535 }
4536 else
4537 result = simplify_transformation_to_array (result, e, dim, NULL,
4538 add_squared, &do_sqrt);
4539
4540 return result;
4541}
4542
4543
6de9cd9a 4544gfc_expr *
edf1eac2 4545gfc_simplify_not (gfc_expr *e)
6de9cd9a
DN		 4546{
4547 gfc_expr *result;
6de9cd9a
DN		 4548
4549 if (e->expr_type != EXPR_CONSTANT)
4550 return NULL;
4551
b7e75771 4552 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6de9cd9a
DN		 4553 mpz_com (result->value.integer, e->value.integer);
4554
6de9cd9a
DN		 4555 return range_check (result, "NOT");
4556}
4557
4558
4559gfc_expr *
edf1eac2 4560gfc_simplify_null (gfc_expr *mold)
6de9cd9a
DN		 4561{
4562 gfc_expr *result;
4563
b7e75771 4564 if (mold)
6de9cd9a 4565 {
b7e75771
JD		 4566 result = gfc_copy_expr (mold);
4567 result->expr_type = EXPR_NULL;
6de9cd9a 4568 }
def66134 4569 else
b7e75771 4570 result = gfc_get_null_expr (NULL);
6de9cd9a
DN		 4571
4572 return result;
4573}
4574
4575
d0a4a61c
TB		 4576gfc_expr *
4577gfc_simplify_num_images (void)
4578{
4579 gfc_expr *result;
64f002ed
TB		 4580
4581 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
4582 {
4583 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
4584 return &gfc_bad_expr;
4585 }
4586
60386f50
TB		 4587 if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
4588 return NULL;
4589
d0a4a61c 4590 /* FIXME: gfc_current_locus is wrong. */
b7e75771
JD		 4591 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4592 &gfc_current_locus);
d0a4a61c
TB		 4593 mpz_set_si (result->value.integer, 1);
4594 return result;
4595}
4596
4597
5d723e54 4598gfc_expr *
edf1eac2 4599gfc_simplify_or (gfc_expr *x, gfc_expr *y)
5d723e54
FXC		 4600{
4601 gfc_expr *result;
4602 int kind;
4603
4604 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4605 return NULL;
4606
4607 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
b7e75771
JD		 4608
4609 switch (x->ts.type)
5d723e54 4610 {
b7e75771
JD		 4611 case BT_INTEGER:
4612 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
4613 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
4614 return range_check (result, "OR");
4615
4616 case BT_LOGICAL:
4617 return gfc_get_logical_expr (kind, &x->where,
4618 x->value.logical || y->value.logical);
4619 default:
4620 gcc_unreachable();
5d723e54 4621 }
5d723e54
FXC		 4622}
4623
4624
7ba8c18c
DF		 4625gfc_expr *
4626gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
4627{
4628 gfc_expr *result;
4629 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
4630
524af0d6
JB		 4631 if (!is_constant_array_expr (array)
4632 || !is_constant_array_expr (vector)
7ba8c18c 4633 || (!gfc_is_constant_expr (mask)
524af0d6 4634 && !is_constant_array_expr (mask)))
7ba8c18c
DF		 4635 return NULL;
4636
b7e75771 4637 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
15c2ef5a
PT		 4638 if (array->ts.type == BT_DERIVED)
4639 result->ts.u.derived = array->ts.u.derived;
7ba8c18c 4640
b7e75771
JD		 4641 array_ctor = gfc_constructor_first (array->value.constructor);
4642 vector_ctor = vector
4643 ? gfc_constructor_first (vector->value.constructor)
4644 : NULL;
7ba8c18c
DF		 4645
4646 if (mask->expr_type == EXPR_CONSTANT
4647 && mask->value.logical)
4648 {
4649 /* Copy all elements of ARRAY to RESULT. */
4650 while (array_ctor)
4651 {
b7e75771
JD		 4652 gfc_constructor_append_expr (&result->value.constructor,
4653 gfc_copy_expr (array_ctor->expr),
4654 NULL);
7ba8c18c 4655
b7e75771
JD		 4656 array_ctor = gfc_constructor_next (array_ctor);
4657 vector_ctor = gfc_constructor_next (vector_ctor);
7ba8c18c
DF		 4658 }
4659 }
4660 else if (mask->expr_type == EXPR_ARRAY)
4661 {
8b704316 4662 /* Copy only those elements of ARRAY to RESULT whose
7ba8c18c 4663 MASK equals .TRUE.. */
b7e75771 4664 mask_ctor = gfc_constructor_first (mask->value.constructor);
7ba8c18c
DF		 4665 while (mask_ctor)
4666 {
4667 if (mask_ctor->expr->value.logical)
4668 {
b7e75771
JD		 4669 gfc_constructor_append_expr (&result->value.constructor,
4670 gfc_copy_expr (array_ctor->expr),
4671 NULL);
4672 vector_ctor = gfc_constructor_next (vector_ctor);
7ba8c18c
DF		 4673 }
4674
b7e75771
JD		 4675 array_ctor = gfc_constructor_next (array_ctor);
4676 mask_ctor = gfc_constructor_next (mask_ctor);
7ba8c18c
DF		 4677 }
4678 }
4679
4680 /* Append any left-over elements from VECTOR to RESULT. */
4681 while (vector_ctor)
4682 {
b7e75771
JD		 4683 gfc_constructor_append_expr (&result->value.constructor,
4684 gfc_copy_expr (vector_ctor->expr),
4685 NULL);
4686 vector_ctor = gfc_constructor_next (vector_ctor);
7ba8c18c
DF		 4687 }
4688
4689 result->shape = gfc_get_shape (1);
4690 gfc_array_size (result, &result->shape[0]);
4691
4692 if (array->ts.type == BT_CHARACTER)
bc21d315 4693 result->ts.u.cl = array->ts.u.cl;
7ba8c18c
DF		 4694
4695 return result;
4696}
4697
4698
0cd0559e
TB		 4699static gfc_expr *
4700do_xor (gfc_expr *result, gfc_expr *e)
4701{
4702 gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
4703 gcc_assert (result->ts.type == BT_LOGICAL
4704 && result->expr_type == EXPR_CONSTANT);
4705
4706 result->value.logical = result->value.logical != e->value.logical;
4707 return result;
4708}
4709
4710
4711
4712gfc_expr *
4713gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
4714{
195a95c4 4715 return simplify_transformation (e, dim, NULL, 0, do_xor);
0cd0559e
TB		 4716}
4717
4718
ad5f4de2
FXC		 4719gfc_expr *
4720gfc_simplify_popcnt (gfc_expr *e)
4721{
4722 int res, k;
4723 mpz_t x;
4724
4725 if (e->expr_type != EXPR_CONSTANT)
4726 return NULL;
4727
4728 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4729
4730 /* Convert argument to unsigned, then count the '1' bits. */
4731 mpz_init_set (x, e->value.integer);
4732 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
4733 res = mpz_popcount (x);
4734 mpz_clear (x);
4735
4736 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
4737}
4738
4739
4740gfc_expr *
4741gfc_simplify_poppar (gfc_expr *e)
4742{
4743 gfc_expr *popcnt;
4744 const char *s;
4745 int i;
4746
4747 if (e->expr_type != EXPR_CONSTANT)
4748 return NULL;
4749
4750 popcnt = gfc_simplify_popcnt (e);
4751 gcc_assert (popcnt);
4752
4753 s = gfc_extract_int (popcnt, &i);
4754 gcc_assert (!s);
4755
4756 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
4757}
4758
4759
6de9cd9a 4760gfc_expr *
edf1eac2 4761gfc_simplify_precision (gfc_expr *e)
6de9cd9a 4762{
b7e75771
JD		 4763 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4764 return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
4765 gfc_real_kinds[i].precision);
6de9cd9a
DN		 4766}
4767
4768
a16d978f
DF		 4769gfc_expr *
4770gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
4771{
195a95c4 4772 return simplify_transformation (array, dim, mask, 1, gfc_multiply);
a16d978f
DF		 4773}
4774
4775
6de9cd9a 4776gfc_expr *
edf1eac2 4777gfc_simplify_radix (gfc_expr *e)
6de9cd9a 4778{
6de9cd9a 4779 int i;
e7a2d5fb 4780 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
b7e75771 4781
6de9cd9a
DN		 4782 switch (e->ts.type)
4783 {
b7e75771
JD		 4784 case BT_INTEGER:
4785 i = gfc_integer_kinds[i].radix;
4786 break;
6de9cd9a 4787
b7e75771
JD		 4788 case BT_REAL:
4789 i = gfc_real_kinds[i].radix;
4790 break;
6de9cd9a 4791
b7e75771
JD		 4792 default:
4793 gcc_unreachable ();
6de9cd9a
DN		 4794 }
4795
b7e75771 4796 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6de9cd9a
DN		 4797}
4798
4799
4800gfc_expr *
edf1eac2 4801gfc_simplify_range (gfc_expr *e)
6de9cd9a 4802{
6de9cd9a 4803 int i;
e7a2d5fb 4804 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6de9cd9a
DN		 4805
4806 switch (e->ts.type)
4807 {
b7e75771
JD		 4808 case BT_INTEGER:
4809 i = gfc_integer_kinds[i].range;
4810 break;
6de9cd9a 4811
b7e75771
JD		 4812 case BT_REAL:
4813 case BT_COMPLEX:
4814 i = gfc_real_kinds[i].range;
4815 break;
6de9cd9a 4816
b7e75771
JD		 4817 default:
4818 gcc_unreachable ();
6de9cd9a
DN		 4819 }
4820
b7e75771 4821 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6de9cd9a
DN		 4822}
4823
4824
2514987f
TB		 4825gfc_expr *
4826gfc_simplify_rank (gfc_expr *e)
4827{
c62c6622
TB		 4828 /* Assumed rank. */
4829 if (e->rank == -1)
4830 return NULL;
4831
2514987f
TB		 4832 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
4833}
4834
4835
6de9cd9a 4836gfc_expr *
edf1eac2 4837gfc_simplify_real (gfc_expr *e, gfc_expr *k)
6de9cd9a 4838{
9e23c1aa 4839 gfc_expr *result = NULL;
6de9cd9a
DN		 4840 int kind;
4841
4842 if (e->ts.type == BT_COMPLEX)
4843 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
4844 else
9d64df18 4845 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
6de9cd9a
DN		 4846
4847 if (kind == -1)
4848 return &gfc_bad_expr;
4849
4850 if (e->expr_type != EXPR_CONSTANT)
4851 return NULL;
4852
b7e75771
JD		 4853 if (convert_boz (e, kind) == &gfc_bad_expr)
4854 return &gfc_bad_expr;
6de9cd9a 4855
b7e75771
JD		 4856 result = gfc_convert_constant (e, BT_REAL, kind);
4857 if (result == &gfc_bad_expr)
4858 return &gfc_bad_expr;
d93712d9 4859
6de9cd9a
DN		 4860 return range_check (result, "REAL");
4861}
4862
6970fcc8
SK		 4863
4864gfc_expr *
edf1eac2 4865gfc_simplify_realpart (gfc_expr *e)
6970fcc8
SK		 4866{
4867 gfc_expr *result;
4868
4869 if (e->expr_type != EXPR_CONSTANT)
4870 return NULL;
4871
b7e75771 4872 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
eb6f9a86 4873 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
b7e75771 4874
6970fcc8
SK		 4875 return range_check (result, "REALPART");
4876}
4877
6de9cd9a 4878gfc_expr *
edf1eac2 4879gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
6de9cd9a
DN		 4880{
4881 gfc_expr *result;
f1412ca5
FXC		 4882 int i, j, len, ncop, nlen;
4883 mpz_t ncopies;
64f4bedf 4884 bool have_length = false;
6de9cd9a 4885
f1412ca5
FXC		 4886 /* If NCOPIES isn't a constant, there's nothing we can do. */
4887 if (n->expr_type != EXPR_CONSTANT)
6de9cd9a
DN		 4888 return NULL;
4889
f1412ca5
FXC		 4890 /* If NCOPIES is negative, it's an error. */
4891 if (mpz_sgn (n->value.integer) < 0)
6de9cd9a 4892 {
f1412ca5
FXC		 4893 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
4894 &n->where);
6de9cd9a
DN		 4895 return &gfc_bad_expr;
4896 }
4897
f1412ca5 4898 /* If we don't know the character length, we can do no more. */
bc21d315
JW		 4899 if (e->ts.u.cl && e->ts.u.cl->length
4900 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
64f4bedf 4901 {
bc21d315 4902 len = mpz_get_si (e->ts.u.cl->length->value.integer);
64f4bedf
PT		 4903 have_length = true;
4904 }
4905 else if (e->expr_type == EXPR_CONSTANT
bc21d315 4906 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
64f4bedf
PT		 4907 {
4908 len = e->value.character.length;
4909 }
4910 else
f1412ca5
FXC		 4911 return NULL;
4912
4913 /* If the source length is 0, any value of NCOPIES is valid
4914 and everything behaves as if NCOPIES == 0. */
4915 mpz_init (ncopies);
64f4bedf 4916 if (len == 0)
f1412ca5
FXC		 4917 mpz_set_ui (ncopies, 0);
4918 else
4919 mpz_set (ncopies, n->value.integer);
4920
4921 /* Check that NCOPIES isn't too large. */
64f4bedf 4922 if (len)
f1412ca5 4923 {
64f4bedf 4924 mpz_t max, mlen;
f1412ca5
FXC		 4925 int i;
4926
4927 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
4928 mpz_init (max);
4929 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
64f4bedf
PT		 4930
4931 if (have_length)
4932 {
4933 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
bc21d315 4934 e->ts.u.cl->length->value.integer);
64f4bedf
PT		 4935 }
4936 else
4937 {
4938 mpz_init_set_si (mlen, len);
4939 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
4940 mpz_clear (mlen);
4941 }
f1412ca5
FXC		 4942
4943 /* The check itself. */
4944 if (mpz_cmp (ncopies, max) > 0)
4945 {
4946 mpz_clear (max);
4947 mpz_clear (ncopies);
4948 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
4949 &n->where);
4950 return &gfc_bad_expr;
4951 }
4952
4953 mpz_clear (max);
4954 }
4955 mpz_clear (ncopies);
4956
71172460 4957 /* For further simplification, we need the character string to be
f1412ca5
FXC		 4958 constant. */
4959 if (e->expr_type != EXPR_CONSTANT)
4960 return NULL;
4961
8b704316
PT		 4962 if (len ||
4963 (e->ts.u.cl->length &&
bc21d315 4964 mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
f0fc6ae6
FXC		 4965 {
4966 const char *res = gfc_extract_int (n, &ncop);
4967 gcc_assert (res == NULL);
4968 }
f1412ca5
FXC		 4969 else
4970 ncop = 0;
4971
f1412ca5 4972 if (ncop == 0)
b7e75771 4973 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
6de9cd9a 4974
b7e75771
JD		 4975 len = e->value.character.length;
4976 nlen = ncop * len;
6de9cd9a 4977
b7e75771 4978 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
f1412ca5 4979 for (i = 0; i < ncop; i++)
6de9cd9a 4980 for (j = 0; j < len; j++)
00660189 4981 result->value.character.string[j+i*len]= e->value.character.string[j];
6de9cd9a
DN		 4982
4983 result->value.character.string[nlen] = '\0'; /* For debugger */
4984 return result;
4985}
4986
4987
4988/* This one is a bear, but mainly has to do with shuffling elements. */
4989
4990gfc_expr *
edf1eac2
SK		 4991gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
4992 gfc_expr *pad, gfc_expr *order_exp)
6de9cd9a 4993{
6de9cd9a
DN		 4994 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
4995 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
6de9cd9a
DN		 4996 mpz_t index, size;
4997 unsigned long j;
4998 size_t nsource;
b7e75771 4999 gfc_expr *e, *result;
6de9cd9a 5000
207bde5f 5001 /* Check that argument expression types are OK. */
535ff342
DF		 5002 if (!is_constant_array_expr (source)
5003 || !is_constant_array_expr (shape_exp)
5004 || !is_constant_array_expr (pad)
5005 || !is_constant_array_expr (order_exp))
6de9cd9a
DN		 5006 return NULL;
5007
207bde5f
JD		 5008 /* Proceed with simplification, unpacking the array. */
5009
6de9cd9a
DN		 5010 mpz_init (index);
5011 rank = 0;
6de9cd9a
DN		 5012
5013 for (;;)
5014 {
b7e75771 5015 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
6de9cd9a
DN		 5016 if (e == NULL)
5017 break;
5018
535ff342 5019 gfc_extract_int (e, &shape[rank]);
6de9cd9a 5020
535ff342
DF		 5021 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
5022 gcc_assert (shape[rank] >= 0);
6de9cd9a
DN		 5023
5024 rank++;
5025 }
5026
535ff342 5027 gcc_assert (rank > 0);
6de9cd9a
DN		 5028
5029 /* Now unpack the order array if present. */
5030 if (order_exp == NULL)
5031 {
5032 for (i = 0; i < rank; i++)
5033 order[i] = i;
6de9cd9a
DN		 5034 }
5035 else
5036 {
6de9cd9a
DN		 5037 for (i = 0; i < rank; i++)
5038 x[i] = 0;
5039
5040 for (i = 0; i < rank; i++)
5041 {
b7e75771 5042 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
535ff342 5043 gcc_assert (e);
6de9cd9a 5044
535ff342 5045 gfc_extract_int (e, &order[i]);
d93712d9 5046
535ff342
DF		 5047 gcc_assert (order[i] >= 1 && order[i] <= rank);
5048 order[i]--;
5049 gcc_assert (x[order[i]] == 0);
6de9cd9a
DN		 5050 x[order[i]] = 1;
5051 }
5052 }
5053
5054 /* Count the elements in the source and padding arrays. */
5055
5056 npad = 0;
5057 if (pad != NULL)
5058 {
5059 gfc_array_size (pad, &size);
5060 npad = mpz_get_ui (size);
5061 mpz_clear (size);
5062 }
5063
5064 gfc_array_size (source, &size);
5065 nsource = mpz_get_ui (size);
5066 mpz_clear (size);
5067
5068 /* If it weren't for that pesky permutation we could just loop
5069 through the source and round out any shortage with pad elements.
5070 But no, someone just had to have the compiler do something the
5071 user should be doing. */
5072
5073 for (i = 0; i < rank; i++)
5074 x[i] = 0;
5075
b7e75771
JD		 5076 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5077 &source->where);
15c2ef5a
PT		 5078 if (source->ts.type == BT_DERIVED)
5079 result->ts.u.derived = source->ts.u.derived;
b7e75771
JD		 5080 result->rank = rank;
5081 result->shape = gfc_get_shape (rank);
5082 for (i = 0; i < rank; i++)
5083 mpz_init_set_ui (result->shape[i], shape[i]);
5084
f7cfd28c 5085 while (nsource > 0 || npad > 0)
6de9cd9a
DN		 5086 {
5087 /* Figure out which element to extract. */
5088 mpz_set_ui (index, 0);
5089
5090 for (i = rank - 1; i >= 0; i--)
5091 {
5092 mpz_add_ui (index, index, x[order[i]]);
5093 if (i != 0)
5094 mpz_mul_ui (index, index, shape[order[i - 1]]);
5095 }
5096
5097 if (mpz_cmp_ui (index, INT_MAX) > 0)
d93712d9 5098 gfc_internal_error ("Reshaped array too large at %C");
6de9cd9a
DN		 5099
5100 j = mpz_get_ui (index);
5101
5102 if (j < nsource)
b7e75771 5103 e = gfc_constructor_lookup_expr (source->value.constructor, j);
6de9cd9a
DN		 5104 else
5105 {
535ff342 5106 gcc_assert (npad > 0);
6de9cd9a 5107
535ff342 5108 j = j - nsource;
6de9cd9a 5109 j = j % npad;
b7e75771 5110 e = gfc_constructor_lookup_expr (pad->value.constructor, j);
6de9cd9a 5111 }
535ff342 5112 gcc_assert (e);
6de9cd9a 5113
b7e75771
JD		 5114 gfc_constructor_append_expr (&result->value.constructor,
5115 gfc_copy_expr (e), &e->where);
6de9cd9a
DN		 5116
5117 /* Calculate the next element. */
5118 i = 0;
5119
5120inc:
5121 if (++x[i] < shape[i])
5122 continue;
5123 x[i++] = 0;
5124 if (i < rank)
5125 goto inc;
5126
5127 break;
5128 }
5129
5130 mpz_clear (index);
5131
b7e75771 5132 return result;
6de9cd9a
DN		 5133}
5134
5135
cc6d3bde 5136gfc_expr *
edf1eac2 5137gfc_simplify_rrspacing (gfc_expr *x)
cc6d3bde
SK		 5138{
5139 gfc_expr *result;
5140 int i;
5141 long int e, p;
5142
5143 if (x->expr_type != EXPR_CONSTANT)
5144 return NULL;
6de9cd9a 5145
cc6d3bde
SK		 5146 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5147
b7e75771 5148 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
cc6d3bde
SK		 5149 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5150
edf1eac2 5151 /* Special case x = -0 and 0. */
cc6d3bde
SK		 5152 if (mpfr_sgn (result->value.real) == 0)
5153 {
5154 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5155 return result;
5156 }
5157
5158 /* | x * 2**(-e) | * 2**p. */
5159 e = - (long int) mpfr_get_exp (x->value.real);
5160 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
5161
5162 p = (long int) gfc_real_kinds[i].digits;
5163 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
5164
5165 return range_check (result, "RRSPACING");
5166}
b814a64e 5167
6de9cd9a
DN		 5168
5169gfc_expr *
edf1eac2 5170gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
6de9cd9a
DN		 5171{
5172 int k, neg_flag, power, exp_range;
f8e566e5 5173 mpfr_t scale, radix;
6de9cd9a
DN		 5174 gfc_expr *result;
5175
5176 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5177 return NULL;
5178
b7e75771 5179 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
6de9cd9a 5180
f8e566e5 5181 if (mpfr_sgn (x->value.real) == 0)
6de9cd9a 5182 {
f8e566e5 5183 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
6de9cd9a
DN		 5184 return result;
5185 }
5186
e7a2d5fb 5187 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6de9cd9a
DN		 5188
5189 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
5190
5191 /* This check filters out values of i that would overflow an int. */
5192 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
5193 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
5194 {
5195 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
d93712d9 5196 gfc_free_expr (result);
6de9cd9a
DN		 5197 return &gfc_bad_expr;
5198 }
5199
5200 /* Compute scale = radix ** power. */
5201 power = mpz_get_si (i->value.integer);
5202
5203 if (power >= 0)
5204 neg_flag = 0;
5205 else
5206 {
5207 neg_flag = 1;
5208 power = -power;
5209 }
5210
f8e566e5
SK		 5211 gfc_set_model_kind (x->ts.kind);
5212 mpfr_init (scale);
5213 mpfr_init (radix);
5214 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
5215 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
6de9cd9a
DN		 5216
5217 if (neg_flag)
f8e566e5 5218 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
6de9cd9a 5219 else
f8e566e5 5220 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
6de9cd9a 5221
7306494a 5222 mpfr_clears (scale, radix, NULL);
6de9cd9a
DN		 5223
5224 return range_check (result, "SCALE");
5225}
5226
5227
00660189
FXC		 5228/* Variants of strspn and strcspn that operate on wide characters. */
5229
5230static size_t
5231wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
5232{
5233 size_t i = 0;
5234 const gfc_char_t *c;
5235
5236 while (s1[i])
5237 {
5238 for (c = s2; *c; c++)
5239 {
5240 if (s1[i] == *c)
5241 break;
5242 }
5243 if (*c == '\0')
5244 break;
5245 i++;
5246 }
5247
5248 return i;
5249}
5250
5251static size_t
5252wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
5253{
5254 size_t i = 0;
5255 const gfc_char_t *c;
5256
5257 while (s1[i])
5258 {
5259 for (c = s2; *c; c++)
5260 {
5261 if (s1[i] == *c)
5262 break;
5263 }
5264 if (*c)
5265 break;
5266 i++;
5267 }
5268
5269 return i;
5270}
5271
5272
6de9cd9a 5273gfc_expr *
5cda5098 5274gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
6de9cd9a
DN		 5275{
5276 gfc_expr *result;
5277 int back;
5278 size_t i;
5279 size_t indx, len, lenc;
5cda5098
FXC		 5280 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
5281
5282 if (k == -1)
5283 return &gfc_bad_expr;
6de9cd9a 5284
61aa9333
TB		 5285 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
5286 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
6de9cd9a
DN		 5287 return NULL;
5288
5289 if (b != NULL && b->value.logical != 0)
5290 back = 1;
5291 else
5292 back = 0;
5293
6de9cd9a
DN		 5294 len = e->value.character.length;
5295 lenc = c->value.character.length;
5296
5297 if (len == 0 || lenc == 0)
5298 {
5299 indx = 0;
5300 }
5301 else
5302 {
5303 if (back == 0)
edf1eac2 5304 {
00660189
FXC		 5305 indx = wide_strcspn (e->value.character.string,
5306 c->value.character.string) + 1;
edf1eac2
SK		 5307 if (indx > len)
5308 indx = 0;
5309 }
6de9cd9a 5310 else
edf1eac2
SK		 5311 {
5312 i = 0;
5313 for (indx = len; indx > 0; indx--)
5314 {
5315 for (i = 0; i < lenc; i++)
5316 {
5317 if (c->value.character.string[i]
5318 == e->value.character.string[indx - 1])
5319 break;
5320 }
5321 if (i < lenc)
5322 break;
5323 }
5324 }
6de9cd9a 5325 }
b7e75771
JD		 5326
5327 result = gfc_get_int_expr (k, &e->where, indx);
6de9cd9a
DN		 5328 return range_check (result, "SCAN");
5329}
5330
5331
a39fafac
FXC		 5332gfc_expr *
5333gfc_simplify_selected_char_kind (gfc_expr *e)
5334{
5335 int kind;
a39fafac
FXC		 5336
5337 if (e->expr_type != EXPR_CONSTANT)
5338 return NULL;
5339
5340 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
5341 || gfc_compare_with_Cstring (e, "default", false) == 0)
5342 kind = 1;
dad80a1b
JD		 5343 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
5344 kind = 4;
a39fafac
FXC		 5345 else
5346 kind = -1;
5347
b7e75771 5348 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
a39fafac
FXC		 5349}
5350
5351
6de9cd9a 5352gfc_expr *
edf1eac2 5353gfc_simplify_selected_int_kind (gfc_expr *e)
6de9cd9a
DN		 5354{
5355 int i, kind, range;
6de9cd9a
DN		 5356
5357 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
5358 return NULL;
5359
5360 kind = INT_MAX;
5361
5362 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
5363 if (gfc_integer_kinds[i].range >= range
5364 && gfc_integer_kinds[i].kind < kind)
5365 kind = gfc_integer_kinds[i].kind;
5366
5367 if (kind == INT_MAX)
5368 kind = -1;
5369
b7e75771 5370 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
6de9cd9a
DN		 5371}
5372
5373
5374gfc_expr *
01349049 5375gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
6de9cd9a 5376{
01349049
TB		 5377 int range, precision, radix, i, kind, found_precision, found_range,
5378 found_radix;
5379 locus *loc = &gfc_current_locus;
6de9cd9a
DN		 5380
5381 if (p == NULL)
5382 precision = 0;
5383 else
5384 {
5385 if (p->expr_type != EXPR_CONSTANT
5386 || gfc_extract_int (p, &precision) != NULL)
5387 return NULL;
01349049 5388 loc = &p->where;
6de9cd9a
DN		 5389 }
5390
5391 if (q == NULL)
5392 range = 0;
5393 else
5394 {
5395 if (q->expr_type != EXPR_CONSTANT
5396 || gfc_extract_int (q, &range) != NULL)
5397 return NULL;
01349049
TB		 5398
5399 if (!loc)
5400 loc = &q->where;
5401 }
5402
5403 if (rdx == NULL)
5404 radix = 0;
5405 else
5406 {
5407 if (rdx->expr_type != EXPR_CONSTANT
5408 || gfc_extract_int (rdx, &radix) != NULL)
5409 return NULL;
5410
5411 if (!loc)
5412 loc = &rdx->where;
6de9cd9a
DN		 5413 }
5414
5415 kind = INT_MAX;
5416 found_precision = 0;
5417 found_range = 0;
01349049 5418 found_radix = 0;
6de9cd9a
DN		 5419
5420 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
5421 {
5422 if (gfc_real_kinds[i].precision >= precision)
5423 found_precision = 1;
5424
5425 if (gfc_real_kinds[i].range >= range)
5426 found_range = 1;
5427
01349049
TB		 5428 if (gfc_real_kinds[i].radix >= radix)
5429 found_radix = 1;
5430
6de9cd9a 5431 if (gfc_real_kinds[i].precision >= precision
01349049
TB		 5432 && gfc_real_kinds[i].range >= range
5433 && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind)
6de9cd9a
DN		 5434 kind = gfc_real_kinds[i].kind;
5435 }
5436
5437 if (kind == INT_MAX)
5438 {
01349049 5439 if (found_radix && found_range && !found_precision)
6de9cd9a 5440 kind = -1;
01349049
TB		 5441 else if (found_radix && found_precision && !found_range)
5442 kind = -2;
5443 else if (found_radix && !found_precision && !found_range)
5444 kind = -3;
5445 else if (found_radix)
5446 kind = -4;
5447 else
5448 kind = -5;
6de9cd9a
DN		 5449 }
5450
01349049 5451 return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
6de9cd9a
DN		 5452}
5453
5454
5455gfc_expr *
edf1eac2 5456gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
6de9cd9a
DN		 5457{
5458 gfc_expr *result;
03ddaf35 5459 mpfr_t exp, absv, log2, pow2, frac;
6de9cd9a
DN		 5460 unsigned long exp2;
5461
5462 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5463 return NULL;
5464
b7e75771 5465 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
6de9cd9a 5466
03ddaf35 5467 if (mpfr_sgn (x->value.real) == 0)
6de9cd9a 5468 {
03ddaf35 5469 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
6de9cd9a
DN		 5470 return result;
5471 }
5472
7306494a 5473 gfc_set_model_kind (x->ts.kind);
f8e566e5 5474 mpfr_init (absv);
03ddaf35
TS		 5475 mpfr_init (log2);
5476 mpfr_init (exp);
f8e566e5
SK		 5477 mpfr_init (pow2);
5478 mpfr_init (frac);
6de9cd9a 5479
f8e566e5 5480 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
03ddaf35 5481 mpfr_log2 (log2, absv, GFC_RND_MODE);
6de9cd9a 5482
03ddaf35
TS		 5483 mpfr_trunc (log2, log2);
5484 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
6de9cd9a
DN		 5485
5486 /* Old exponent value, and fraction. */
03ddaf35 5487 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
6de9cd9a 5488
f8e566e5 5489 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
6de9cd9a
DN		 5490
5491 /* New exponent. */
5492 exp2 = (unsigned long) mpz_get_d (i->value.integer);
f8e566e5 5493 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
6de9cd9a 5494
7306494a 5495 mpfr_clears (absv, log2, pow2, frac, NULL);
6de9cd9a
DN		 5496
5497 return range_check (result, "SET_EXPONENT");
5498}
5499
5500
5501gfc_expr *
7320cf09 5502gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
6de9cd9a
DN		 5503{
5504 mpz_t shape[GFC_MAX_DIMENSIONS];
5505 gfc_expr *result, *e, *f;
5506 gfc_array_ref *ar;
5507 int n;
524af0d6 5508 bool t;
7320cf09 5509 int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
6de9cd9a 5510
d357d991
MM		 5511 if (source->rank == -1)
5512 return NULL;
5513
7320cf09 5514 result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
64a96f5b 5515
7320cf09
TB		 5516 if (source->rank == 0)
5517 return result;
6de9cd9a 5518
69dcd06a
DK		 5519 if (source->expr_type == EXPR_VARIABLE)
5520 {
5521 ar = gfc_find_array_ref (source);
5522 t = gfc_array_ref_shape (ar, shape);
5523 }
5524 else if (source->shape)
5525 {
524af0d6 5526 t = true;
69dcd06a
DK		 5527 for (n = 0; n < source->rank; n++)
5528 {
5529 mpz_init (shape[n]);
5530 mpz_set (shape[n], source->shape[n]);
5531 }
5532 }
5533 else
524af0d6 5534 t = false;
6de9cd9a
DN		 5535
5536 for (n = 0; n < source->rank; n++)
5537 {
7320cf09 5538 e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
6de9cd9a 5539
524af0d6 5540 if (t)
6de9cd9a
DN		 5541 {
5542 mpz_set (e->value.integer, shape[n]);
5543 mpz_clear (shape[n]);
5544 }
5545 else
5546 {
5547 mpz_set_ui (e->value.integer, n + 1);
5548
5cda5098 5549 f = gfc_simplify_size (source, e, NULL);
6de9cd9a
DN		 5550 gfc_free_expr (e);
5551 if (f == NULL)
5552 {
5553 gfc_free_expr (result);
5554 return NULL;
5555 }
5556 else
69dcd06a 5557 e = f;
6de9cd9a
DN		 5558 }
5559
b7e75771 5560 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
6de9cd9a
DN		 5561 }
5562
5563 return result;
5564}
5565
5566
5567gfc_expr *
5cda5098 5568gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6de9cd9a
DN		 5569{
5570 mpz_t size;
9231ff56 5571 gfc_expr *return_value;
6de9cd9a 5572 int d;
a0689cdf 5573 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
5cda5098
FXC		 5574
5575 if (k == -1)
5576 return &gfc_bad_expr;
6de9cd9a 5577
69dcd06a
DK		 5578 /* For unary operations, the size of the result is given by the size
5579 of the operand. For binary ones, it's the size of the first operand
5580 unless it is scalar, then it is the size of the second. */
5581 if (array->expr_type == EXPR_OP && !array->value.op.uop)
5582 {
5583 gfc_expr* replacement;
5584 gfc_expr* simplified;
5585
5586 switch (array->value.op.op)
5587 {
5588 /* Unary operations. */
5589 case INTRINSIC_NOT:
5590 case INTRINSIC_UPLUS:
5591 case INTRINSIC_UMINUS:
1b3f07c7 5592 case INTRINSIC_PARENTHESES:
69dcd06a
DK		 5593 replacement = array->value.op.op1;
5594 break;
5595
5596 /* Binary operations. If any one of the operands is scalar, take
5597 the other one's size. If both of them are arrays, it does not
5598 matter -- try to find one with known shape, if possible. */
5599 default:
5600 if (array->value.op.op1->rank == 0)
5601 replacement = array->value.op.op2;
5602 else if (array->value.op.op2->rank == 0)
5603 replacement = array->value.op.op1;
5604 else
5605 {
5606 simplified = gfc_simplify_size (array->value.op.op1, dim, kind);
5607 if (simplified)
5608 return simplified;
5609
5610 replacement = array->value.op.op2;
5611 }
5612 break;
5613 }
5614
5615 /* Try to reduce it directly if possible. */
5616 simplified = gfc_simplify_size (replacement, dim, kind);
5617
5618 /* Otherwise, we build a new SIZE call. This is hopefully at least
5619 simpler than the original one. */
5620 if (!simplified)
6838c137
TB		 5621 simplified = gfc_build_intrinsic_call (gfc_current_ns,
5622 GFC_ISYM_SIZE, "size",
5623 array->where, 3,
69dcd06a
DK		 5624 gfc_copy_expr (replacement),
5625 gfc_copy_expr (dim),
5626 gfc_copy_expr (kind));
5627
5628 return simplified;
5629 }
5630
6de9cd9a
DN		 5631 if (dim == NULL)
5632 {
524af0d6 5633 if (!gfc_array_size (array, &size))
6de9cd9a
DN		 5634 return NULL;
5635 }
5636 else
5637 {
5638 if (dim->expr_type != EXPR_CONSTANT)
5639 return NULL;
5640
5641 d = mpz_get_ui (dim->value.integer) - 1;
524af0d6 5642 if (!gfc_array_dimen_size (array, d, &size))
6de9cd9a
DN		 5643 return NULL;
5644 }
5645
9231ff56
MM		 5646 return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size));
5647 mpz_clear (size);
5648 return return_value;
6de9cd9a
DN		 5649}
5650
5651
1a8c1e35
TB		 5652/* SIZEOF and C_SIZEOF return the size in bytes of an array element
5653 multiplied by the array size. */
5654
5655gfc_expr *
5656gfc_simplify_sizeof (gfc_expr *x)
5657{
5658 gfc_expr *result = NULL;
5659 mpz_t array_size;
5660
5661 if (x->ts.type == BT_CLASS || x->ts.deferred)
5662 return NULL;
5663
5664 if (x->ts.type == BT_CHARACTER
5665 && (!x->ts.u.cl || !x->ts.u.cl->length
5666 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
5667 return NULL;
5668
5669 if (x->rank && x->expr_type != EXPR_ARRAY
524af0d6 5670 && !gfc_array_size (x, &array_size))
1a8c1e35
TB		 5671 return NULL;
5672
5673 result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5674 &x->where);
5675 mpz_set_si (result->value.integer, gfc_target_expr_size (x));
5676
5677 /* gfc_target_expr_size already takes the array size for array constructors
5678 into account. */
5679 if (x->rank && x->expr_type != EXPR_ARRAY)
5680 {
5681 mpz_mul (result->value.integer, result->value.integer, array_size);
5682 mpz_clear (array_size);
5683 }
5684
5685 return result;
5686}
5687
5688
5689/* STORAGE_SIZE returns the size in bits of a single array element. */
5690
5691gfc_expr *
5692gfc_simplify_storage_size (gfc_expr *x,
5693 gfc_expr *kind)
5694{
5695 gfc_expr *result = NULL;
5696 int k;
5697 size_t elt_size;
5698
5699 if (x->ts.type == BT_CLASS || x->ts.deferred)
5700 return NULL;
5701
5702 if (x->ts.type == BT_CHARACTER
5703 && (!x->ts.u.cl || !x->ts.u.cl->length
5704 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
5705 return NULL;
5706
5707 k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
5708 if (k == -1)
5709 return &gfc_bad_expr;
5710
5711 if (x->expr_type == EXPR_ARRAY)
5712 {
5713 gfc_constructor *c = gfc_constructor_first (x->value.constructor);
5714 elt_size = gfc_target_expr_size (c->expr);
5715 }
5716 else
5717 elt_size = gfc_target_expr_size (x);
5718
5719 result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
5720 &x->where);
5721 mpz_set_si (result->value.integer, elt_size);
5722
5723 mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
5724 return result;
5725}
5726
5727
6de9cd9a 5728gfc_expr *
edf1eac2 5729gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
6de9cd9a
DN		 5730{
5731 gfc_expr *result;
5732
5733 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
5734 return NULL;
5735
b7e75771 5736 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6de9cd9a
DN		 5737
5738 switch (x->ts.type)
5739 {
b7e75771
JD		 5740 case BT_INTEGER:
5741 mpz_abs (result->value.integer, x->value.integer);
5742 if (mpz_sgn (y->value.integer) < 0)
5743 mpz_neg (result->value.integer, result->value.integer);
5744 break;
6de9cd9a 5745
b7e75771
JD		 5746 case BT_REAL:
5747 if (gfc_option.flag_sign_zero)
5748 mpfr_copysign (result->value.real, x->value.real, y->value.real,
5749 GFC_RND_MODE);
5750 else
5751 mpfr_setsign (result->value.real, x->value.real,
5752 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
5753 break;
6de9cd9a 5754
b7e75771
JD		 5755 default:
5756 gfc_internal_error ("Bad type in gfc_simplify_sign");
6de9cd9a
DN		 5757 }
5758
5759 return result;
5760}
5761
5762
5763gfc_expr *
edf1eac2 5764gfc_simplify_sin (gfc_expr *x)
6de9cd9a
DN		 5765{
5766 gfc_expr *result;
6de9cd9a
DN		 5767
5768 if (x->expr_type != EXPR_CONSTANT)
5769 return NULL;
5770
b7e75771 5771 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6de9cd9a
DN		 5772
5773 switch (x->ts.type)
5774 {
b7e75771
JD		 5775 case BT_REAL:
5776 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
5777 break;
6de9cd9a 5778
b7e75771
JD		 5779 case BT_COMPLEX:
5780 gfc_set_model (x->value.real);
5781 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5782 break;
6de9cd9a 5783
b7e75771
JD		 5784 default:
5785 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
6de9cd9a
DN		 5786 }
5787
5788 return range_check (result, "SIN");
5789}
5790
5791
5792gfc_expr *
edf1eac2 5793gfc_simplify_sinh (gfc_expr *x)
6de9cd9a
DN		 5794{
5795 gfc_expr *result;
5796
5797 if (x->expr_type != EXPR_CONSTANT)
5798 return NULL;
5799
b7e75771 5800 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6de9cd9a 5801
b7e75771
JD		 5802 switch (x->ts.type)
5803 {
5804 case BT_REAL:
5805 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
5806 break;
5807
5808 case BT_COMPLEX:
5809 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5810 break;
504ed63a 5811
b7e75771
JD		 5812 default:
5813 gcc_unreachable ();
5814 }
6de9cd9a
DN		 5815
5816 return range_check (result, "SINH");
5817}
5818
5819
5820/* The argument is always a double precision real that is converted to
5821 single precision. TODO: Rounding! */
5822
5823gfc_expr *
edf1eac2 5824gfc_simplify_sngl (gfc_expr *a)
6de9cd9a
DN		 5825{
5826 gfc_expr *result;
5827
5828 if (a->expr_type != EXPR_CONSTANT)
5829 return NULL;
5830
9d64df18 5831 result = gfc_real2real (a, gfc_default_real_kind);
6de9cd9a
DN		 5832 return range_check (result, "SNGL");
5833}
5834
6de9cd9a 5835
cc6d3bde 5836gfc_expr *
edf1eac2 5837gfc_simplify_spacing (gfc_expr *x)
cc6d3bde
SK		 5838{
5839 gfc_expr *result;
5840 int i;
5841 long int en, ep;
6de9cd9a 5842
cc6d3bde
SK		 5843 if (x->expr_type != EXPR_CONSTANT)
5844 return NULL;
5845
5846 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5847
b7e75771 5848 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
cc6d3bde
SK		 5849
5850 /* Special case x = 0 and -0. */
5851 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5852 if (mpfr_sgn (result->value.real) == 0)
5853 {
5854 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
5855 return result;
5856 }
5857
5858 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
8b704316 5859 are the radix, exponent of x, and precision. This excludes the
cc6d3bde
SK		 5860 possibility of subnormal numbers. Fortran 2003 states the result is
5861 b**max(e - p, emin - 1). */
5862
5863 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
5864 en = (long int) gfc_real_kinds[i].min_exponent - 1;
5865 en = en > ep ? en : ep;
5866
5867 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
5868 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
5869
5870 return range_check (result, "SPACING");
5871}
b814a64e 5872
6de9cd9a 5873
c430a6f9
DF		 5874gfc_expr *
5875gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
5876{
5877 gfc_expr *result = 0L;
5878 int i, j, dim, ncopies;
0e6640d8 5879 mpz_t size;
c430a6f9
DF		 5880
5881 if ((!gfc_is_constant_expr (source)
5882 && !is_constant_array_expr (source))
5883 || !gfc_is_constant_expr (dim_expr)
5884 || !gfc_is_constant_expr (ncopies_expr))
5885 return NULL;
5886
5887 gcc_assert (dim_expr->ts.type == BT_INTEGER);
5888 gfc_extract_int (dim_expr, &dim);
5889 dim -= 1; /* zero-base DIM */
5890
5891 gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
5892 gfc_extract_int (ncopies_expr, &ncopies);
5893 ncopies = MAX (ncopies, 0);
5894
0e6640d8
PT		 5895 /* Do not allow the array size to exceed the limit for an array
5896 constructor. */
e5e85f2b
TB		 5897 if (source->expr_type == EXPR_ARRAY)
5898 {
524af0d6 5899 if (!gfc_array_size (source, &size))
e5e85f2b
TB		 5900 gfc_internal_error ("Failure getting length of a constant array.");
5901 }
5902 else
5903 mpz_init_set_ui (size, 1);
5904
0e6640d8
PT		 5905 if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
5906 return NULL;
5907
c430a6f9
DF		 5908 if (source->expr_type == EXPR_CONSTANT)
5909 {
5910 gcc_assert (dim == 0);
5911
b7e75771
JD		 5912 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5913 &source->where);
15c2ef5a
PT		 5914 if (source->ts.type == BT_DERIVED)
5915 result->ts.u.derived = source->ts.u.derived;
c430a6f9
DF		 5916 result->rank = 1;
5917 result->shape = gfc_get_shape (result->rank);
5918 mpz_init_set_si (result->shape[0], ncopies);
5919
5920 for (i = 0; i < ncopies; ++i)
b7e75771
JD		 5921 gfc_constructor_append_expr (&result->value.constructor,
5922 gfc_copy_expr (source), NULL);
c430a6f9
DF		 5923 }
5924 else if (source->expr_type == EXPR_ARRAY)
5925 {
b7e75771
JD		 5926 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
5927 gfc_constructor *source_ctor;
c430a6f9
DF		 5928
5929 gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
5930 gcc_assert (dim >= 0 && dim <= source->rank);
5931
b7e75771
JD		 5932 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5933 &source->where);
15c2ef5a
PT		 5934 if (source->ts.type == BT_DERIVED)
5935 result->ts.u.derived = source->ts.u.derived;
c430a6f9
DF		 5936 result->rank = source->rank + 1;
5937 result->shape = gfc_get_shape (result->rank);
5938
c430a6f9
DF		 5939 for (i = 0, j = 0; i < result->rank; ++i)
5940 {
5941 if (i != dim)
5942 mpz_init_set (result->shape[i], source->shape[j++]);
5943 else
5944 mpz_init_set_si (result->shape[i], ncopies);
5945
5946 extent[i] = mpz_get_si (result->shape[i]);
5947 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
c430a6f9
DF		 5948 }
5949
b7e75771
JD		 5950 offset = 0;
5951 for (source_ctor = gfc_constructor_first (source->value.constructor);
5952 source_ctor; source_ctor = gfc_constructor_next (source_ctor))
c430a6f9 5953 {
c430a6f9 5954 for (i = 0; i < ncopies; ++i)
b7e75771
JD		 5955 gfc_constructor_insert_expr (&result->value.constructor,
5956 gfc_copy_expr (source_ctor->expr),
5957 NULL, offset + i * rstride[dim]);
c430a6f9 5958
b7e75771 5959 offset += (dim == 0 ? ncopies : 1);
c430a6f9
DF		 5960 }
5961 }
5962 else
5963 /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
5964 Replace NULL with gcc_unreachable() after implementing
5965 gfc_simplify_cshift(). */
5966 return NULL;
5967
5968 if (source->ts.type == BT_CHARACTER)
bc21d315 5969 result->ts.u.cl = source->ts.u.cl;
c430a6f9
DF		 5970
5971 return result;
5972}
5973
5974
6de9cd9a 5975gfc_expr *
edf1eac2 5976gfc_simplify_sqrt (gfc_expr *e)
6de9cd9a 5977{
b7e75771 5978 gfc_expr *result = NULL;
6de9cd9a
DN		 5979
5980 if (e->expr_type != EXPR_CONSTANT)
5981 return NULL;
5982
6de9cd9a
DN		 5983 switch (e->ts.type)
5984 {
b7e75771
JD		 5985 case BT_REAL:
5986 if (mpfr_cmp_si (e->value.real, 0) < 0)
5987 {
5988 gfc_error ("Argument of SQRT at %L has a negative value",
5989 &e->where);
5990 return &gfc_bad_expr;
5991 }
5992 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
5993 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
5994 break;
6de9cd9a 5995
b7e75771
JD		 5996 case BT_COMPLEX:
5997 gfc_set_model (e->value.real);
6de9cd9a 5998
b7e75771
JD		 5999 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6000 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
6001 break;
6de9cd9a 6002
b7e75771
JD		 6003 default:
6004 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
6de9cd9a
DN		 6005 }
6006
6007 return range_check (result, "SQRT");
6de9cd9a
DN		 6008}
6009
6010
a16d978f
DF		 6011gfc_expr *
6012gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
6013{
195a95c4 6014 return simplify_transformation (array, dim, mask, 0, gfc_add);
a16d978f
DF		 6015}
6016
6017
6de9cd9a 6018gfc_expr *
edf1eac2 6019gfc_simplify_tan (gfc_expr *x)
6de9cd9a 6020{
f8e566e5 6021 gfc_expr *result;
6de9cd9a
DN		 6022
6023 if (x->expr_type != EXPR_CONSTANT)
6024 return NULL;
6025
b7e75771 6026 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6de9cd9a 6027
b7e75771
JD		 6028 switch (x->ts.type)
6029 {
6030 case BT_REAL:
6031 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
6032 break;
6033
6034 case BT_COMPLEX:
6035 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6036 break;
6037
6038 default:
6039 gcc_unreachable ();
6040 }
6de9cd9a
DN		 6041
6042 return range_check (result, "TAN");
6043}
6044
6045
6046gfc_expr *
edf1eac2 6047gfc_simplify_tanh (gfc_expr *x)
6de9cd9a
DN		 6048{
6049 gfc_expr *result;
6de9cd9a
DN		 6050
6051 if (x->expr_type != EXPR_CONSTANT)
6052 return NULL;
6053
b7e75771 6054 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6de9cd9a 6055
b7e75771
JD		 6056 switch (x->ts.type)
6057 {
6058 case BT_REAL:
6059 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
6060 break;
6de9cd9a 6061
b7e75771
JD		 6062 case BT_COMPLEX:
6063 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6064 break;
6065
6066 default:
6067 gcc_unreachable ();
6068 }
6de9cd9a 6069
b7e75771 6070 return range_check (result, "TANH");
6de9cd9a
DN		 6071}
6072
6073
6074gfc_expr *
edf1eac2 6075gfc_simplify_tiny (gfc_expr *e)
6de9cd9a
DN		 6076{
6077 gfc_expr *result;
6078 int i;
6079
e7a2d5fb 6080 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
6de9cd9a 6081
b7e75771 6082 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
f8e566e5 6083 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
6de9cd9a
DN		 6084
6085 return result;
6086}
6087
6088
414f00e9
SB		 6089gfc_expr *
6090gfc_simplify_trailz (gfc_expr *e)
6091{
414f00e9
SB		 6092 unsigned long tz, bs;
6093 int i;
6094
6095 if (e->expr_type != EXPR_CONSTANT)
6096 return NULL;
6097
6098 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6099 bs = gfc_integer_kinds[i].bit_size;
6100 tz = mpz_scan1 (e->value.integer, 0);
6101
b7e75771
JD		 6102 return gfc_get_int_expr (gfc_default_integer_kind,
6103 &e->where, MIN (tz, bs));
414f00e9
SB		 6104}
6105
6106
a4a11197 6107gfc_expr *
edf1eac2 6108gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
a4a11197 6109{
7433458d
PT		 6110 gfc_expr *result;
6111 gfc_expr *mold_element;
6112 size_t source_size;
6113 size_t result_size;
7433458d
PT		 6114 size_t buffer_size;
6115 mpz_t tmp;
6116 unsigned char *buffer;
86dbed7d
TK		 6117 size_t result_length;
6118
a4a11197 6119
7433458d 6120 if (!gfc_is_constant_expr (source)
f2cbd86c 6121 || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
7433458d
PT		 6122 || !gfc_is_constant_expr (size))
6123 return NULL;
6124
524af0d6
JB		 6125 if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
6126 &result_size, &result_length))
2dc95548
PT		 6127 return NULL;
6128
7433458d
PT		 6129 /* Calculate the size of the source. */
6130 if (source->expr_type == EXPR_ARRAY
524af0d6 6131 && !gfc_array_size (source, &tmp))
7433458d
PT		 6132 gfc_internal_error ("Failure getting length of a constant array.");
6133
7433458d 6134 /* Create an empty new expression with the appropriate characteristics. */
b7e75771
JD		 6135 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
6136 &source->where);
7433458d
PT		 6137 result->ts = mold->ts;
6138
6139 mold_element = mold->expr_type == EXPR_ARRAY
b7e75771 6140 ? gfc_constructor_first (mold->value.constructor)->expr
7433458d
PT		 6141 : mold;
6142
6143 /* Set result character length, if needed. Note that this needs to be
8b704316 6144 set even for array expressions, in order to pass this information into
7433458d 6145 gfc_target_interpret_expr. */
d9183bb7 6146 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
7433458d 6147 result->value.character.length = mold_element->value.character.length;
8b704316 6148
7433458d 6149 /* Set the number of elements in the result, and determine its size. */
d9183bb7 6150
e7c8ff56 6151 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
7433458d 6152 {
7433458d
PT		 6153 result->expr_type = EXPR_ARRAY;
6154 result->rank = 1;
7433458d
PT		 6155 result->shape = gfc_get_shape (1);
6156 mpz_init_set_ui (result->shape[0], result_length);
7433458d
PT		 6157 }
6158 else
86dbed7d 6159 result->rank = 0;
92ebaacd 6160
7433458d
PT		 6161 /* Allocate the buffer to store the binary version of the source. */
6162 buffer_size = MAX (source_size, result_size);
6163 buffer = (unsigned char*)alloca (buffer_size);
47ed69db 6164 memset (buffer, 0, buffer_size);
7433458d
PT		 6165
6166 /* Now write source to the buffer. */
6167 gfc_target_encode_expr (source, buffer, buffer_size);
6168
6169 /* And read the buffer back into the new expression. */
86dbed7d 6170 gfc_target_interpret_expr (buffer, buffer_size, result, false);
7433458d
PT		 6171
6172 return result;
a4a11197
PT		 6173}
6174
6175
8ec259c1
DF		 6176gfc_expr *
6177gfc_simplify_transpose (gfc_expr *matrix)
6178{
b7e75771 6179 int row, matrix_rows, col, matrix_cols;
8ec259c1 6180 gfc_expr *result;
8ec259c1
DF		 6181
6182 if (!is_constant_array_expr (matrix))
6183 return NULL;
6184
6185 gcc_assert (matrix->rank == 2);
6186
b7e75771
JD		 6187 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
6188 &matrix->where);
8ec259c1
DF		 6189 result->rank = 2;
6190 result->shape = gfc_get_shape (result->rank);
6191 mpz_set (result->shape[0], matrix->shape[1]);
6192 mpz_set (result->shape[1], matrix->shape[0]);
6193
6194 if (matrix->ts.type == BT_CHARACTER)
bc21d315 6195 result->ts.u.cl = matrix->ts.u.cl;
15c2ef5a
PT		 6196 else if (matrix->ts.type == BT_DERIVED)
6197 result->ts.u.derived = matrix->ts.u.derived;
8ec259c1
DF		 6198
6199 matrix_rows = mpz_get_si (matrix->shape[0]);
b7e75771
JD		 6200 matrix_cols = mpz_get_si (matrix->shape[1]);
6201 for (row = 0; row < matrix_rows; ++row)
6202 for (col = 0; col < matrix_cols; ++col)
6203 {
6204 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
6205 col * matrix_rows + row);
8b704316 6206 gfc_constructor_insert_expr (&result->value.constructor,
b7e75771
JD		 6207 gfc_copy_expr (e), &matrix->where,
6208 row * matrix_cols + col);
6209 }
8ec259c1
DF		 6210
6211 return result;
6212}
6213
6214
6de9cd9a 6215gfc_expr *
edf1eac2 6216gfc_simplify_trim (gfc_expr *e)
6de9cd9a
DN		 6217{
6218 gfc_expr *result;
6219 int count, i, len, lentrim;
6220
6221 if (e->expr_type != EXPR_CONSTANT)
6222 return NULL;
6223
6224 len = e->value.character.length;
6de9cd9a
DN		 6225 for (count = 0, i = 1; i <= len; ++i)
6226 {
6227 if (e->value.character.string[len - i] == ' ')
6228 count++;
6229 else
6230 break;
6231 }
6232
6233 lentrim = len - count;
6234
b7e75771 6235 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
6de9cd9a
DN		 6236 for (i = 0; i < lentrim; i++)
6237 result->value.character.string[i] = e->value.character.string[i];
6238
6de9cd9a
DN		 6239 return result;
6240}
6241
6242
64f002ed
TB		 6243gfc_expr *
6244gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
6245{
6246 gfc_expr *result;
6247 gfc_ref *ref;
6248 gfc_array_spec *as;
6249 gfc_constructor *sub_cons;
6250 bool first_image;
6251 int d;
6252
6253 if (!is_constant_array_expr (sub))
5af07930 6254 return NULL;
64f002ed
TB		 6255
6256 /* Follow any component references. */
6257 as = coarray->symtree->n.sym->as;
6258 for (ref = coarray->ref; ref; ref = ref->next)
6259 if (ref->type == REF_COMPONENT)
6260 as = ref->u.ar.as;
6261
6262 if (as->type == AS_DEFERRED)
5af07930 6263 return NULL;
64f002ed
TB		 6264
6265 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6266 the cosubscript addresses the first image. */
6267
6268 sub_cons = gfc_constructor_first (sub->value.constructor);
6269 first_image = true;
6270
6271 for (d = 1; d <= as->corank; d++)
6272 {
6273 gfc_expr *ca_bound;
6274 int cmp;
6275
e84b920c 6276 gcc_assert (sub_cons != NULL);
64f002ed
TB		 6277
6278 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
6279 NULL, true);
6280 if (ca_bound == NULL)
5af07930 6281 return NULL;
64f002ed
TB		 6282
6283 if (ca_bound == &gfc_bad_expr)
6284 return ca_bound;
6285
6286 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
6287
6288 if (cmp == 0)
6289 {
6290 gfc_free_expr (ca_bound);
6291 sub_cons = gfc_constructor_next (sub_cons);
6292 continue;
6293 }
6294
6295 first_image = false;
6296
6297 if (cmp > 0)
6298 {
6299 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6300 "SUB has %ld and COARRAY lower bound is %ld)",
6301 &coarray->where, d,
6302 mpz_get_si (sub_cons->expr->value.integer),
6303 mpz_get_si (ca_bound->value.integer));
6304 gfc_free_expr (ca_bound);
6305 return &gfc_bad_expr;
6306 }
6307
6308 gfc_free_expr (ca_bound);
6309
6310 /* Check whether upperbound is valid for the multi-images case. */
6311 if (d < as->corank)
6312 {
6313 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
6314 NULL, true);
6315 if (ca_bound == &gfc_bad_expr)
6316 return ca_bound;
6317
6318 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
6319 && mpz_cmp (ca_bound->value.integer,
6320 sub_cons->expr->value.integer) < 0)
6321 {
6322 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6323 "SUB has %ld and COARRAY upper bound is %ld)",
6324 &coarray->where, d,
6325 mpz_get_si (sub_cons->expr->value.integer),
6326 mpz_get_si (ca_bound->value.integer));
6327 gfc_free_expr (ca_bound);
6328 return &gfc_bad_expr;
6329 }
6330
6331 if (ca_bound)
6332 gfc_free_expr (ca_bound);
6333 }
6334
6335 sub_cons = gfc_constructor_next (sub_cons);
6336 }
6337
e84b920c 6338 gcc_assert (sub_cons == NULL);
5af07930
TB		 6339
6340 if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
6341 return NULL;
6342
64f002ed
TB		 6343 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6344 &gfc_current_locus);
6345 if (first_image)
6346 mpz_set_si (result->value.integer, 1);
6347 else
6348 mpz_set_si (result->value.integer, 0);
6349
6350 return result;
64f002ed
TB		 6351}
6352
6353
6354gfc_expr *
6355gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
6356{
60386f50
TB		 6357 if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
6358 return NULL;
6359
64f002ed
TB		 6360 if (coarray == NULL)
6361 {
6362 gfc_expr *result;
6363 /* FIXME: gfc_current_locus is wrong. */
6364 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6365 &gfc_current_locus);
6366 mpz_set_si (result->value.integer, 1);
6367 return result;
6368 }
6369
492792ed
TB		 6370 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
6371 return simplify_cobound (coarray, dim, NULL, 0);
64f002ed
TB		 6372}
6373
6374
6de9cd9a 6375gfc_expr *
5cda5098 6376gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6de9cd9a 6377{
5cda5098 6378 return simplify_bound (array, dim, kind, 1);
6de9cd9a
DN		 6379}
6380
64f002ed
TB		 6381gfc_expr *
6382gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6383{
a3935ffc 6384 return simplify_cobound (array, dim, kind, 1);
64f002ed
TB		 6385}
6386
6de9cd9a 6387
c430a6f9
DF		 6388gfc_expr *
6389gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
6390{
6391 gfc_expr *result, *e;
6392 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
6393
6394 if (!is_constant_array_expr (vector)
6395 || !is_constant_array_expr (mask)
6396 || (!gfc_is_constant_expr (field)
524af0d6 6397 && !is_constant_array_expr (field)))
c430a6f9
DF		 6398 return NULL;
6399
b7e75771
JD		 6400 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
6401 &vector->where);
15c2ef5a
PT		 6402 if (vector->ts.type == BT_DERIVED)
6403 result->ts.u.derived = vector->ts.u.derived;
c430a6f9
DF		 6404 result->rank = mask->rank;
6405 result->shape = gfc_copy_shape (mask->shape, mask->rank);
6406
6407 if (vector->ts.type == BT_CHARACTER)
bc21d315 6408 result->ts.u.cl = vector->ts.u.cl;
c430a6f9 6409
b7e75771
JD		 6410 vector_ctor = gfc_constructor_first (vector->value.constructor);
6411 mask_ctor = gfc_constructor_first (mask->value.constructor);
6412 field_ctor
6413 = field->expr_type == EXPR_ARRAY
6414 ? gfc_constructor_first (field->value.constructor)
6415 : NULL;
c430a6f9
DF		 6416
6417 while (mask_ctor)
6418 {
6419 if (mask_ctor->expr->value.logical)
6420 {
6421 gcc_assert (vector_ctor);
6422 e = gfc_copy_expr (vector_ctor->expr);
b7e75771 6423 vector_ctor = gfc_constructor_next (vector_ctor);
c430a6f9
DF		 6424 }
6425 else if (field->expr_type == EXPR_ARRAY)
6426 e = gfc_copy_expr (field_ctor->expr);
6427 else
6428 e = gfc_copy_expr (field);
6429
b7e75771 6430 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
c430a6f9 6431
b7e75771
JD		 6432 mask_ctor = gfc_constructor_next (mask_ctor);
6433 field_ctor = gfc_constructor_next (field_ctor);
c430a6f9
DF		 6434 }
6435
6436 return result;
6437}
6438
6439
6de9cd9a 6440gfc_expr *
5cda5098 6441gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
6de9cd9a
DN		 6442{
6443 gfc_expr *result;
6444 int back;
6445 size_t index, len, lenset;
6446 size_t i;
5cda5098
FXC		 6447 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
6448
6449 if (k == -1)
6450 return &gfc_bad_expr;
6de9cd9a 6451
61aa9333
TB		 6452 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
6453 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
6de9cd9a
DN		 6454 return NULL;
6455
6456 if (b != NULL && b->value.logical != 0)
6457 back = 1;
6458 else
6459 back = 0;
6460
b7e75771 6461 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
6de9cd9a
DN		 6462
6463 len = s->value.character.length;
6464 lenset = set->value.character.length;
6465
6466 if (len == 0)
6467 {
6468 mpz_set_ui (result->value.integer, 0);
6469 return result;
6470 }
6471
6472 if (back == 0)
6473 {
6474 if (lenset == 0)
6475 {
9202989a 6476 mpz_set_ui (result->value.integer, 1);
6de9cd9a
DN		 6477 return result;
6478 }
6479
00660189
FXC		 6480 index = wide_strspn (s->value.character.string,
6481 set->value.character.string) + 1;
6de9cd9a
DN		 6482 if (index > len)
6483 index = 0;
6484
6485 }
6486 else
6487 {
6488 if (lenset == 0)
6489 {
9202989a 6490 mpz_set_ui (result->value.integer, len);
6de9cd9a
DN		 6491 return result;
6492 }
6493 for (index = len; index > 0; index --)
edf1eac2
SK		 6494 {
6495 for (i = 0; i < lenset; i++)
6496 {
6497 if (s->value.character.string[index - 1]
6498 == set->value.character.string[i])
6499 break;
6500 }
6501 if (i == lenset)
6502 break;
6503 }
6de9cd9a
DN		 6504 }
6505
6506 mpz_set_ui (result->value.integer, index);
6507 return result;
6508}
6509
5d723e54
FXC		 6510
6511gfc_expr *
edf1eac2 6512gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
5d723e54
FXC		 6513{
6514 gfc_expr *result;
6515 int kind;
6516
6517 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6518 return NULL;
6519
6520 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
b7e75771
JD		 6521
6522 switch (x->ts.type)
5d723e54 6523 {
b7e75771
JD		 6524 case BT_INTEGER:
6525 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6526 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
6527 return range_check (result, "XOR");
6528
6529 case BT_LOGICAL:
6530 return gfc_get_logical_expr (kind, &x->where,
6531 (x->value.logical && !y->value.logical)
6532 || (!x->value.logical && y->value.logical));
5d723e54 6533
b7e75771
JD		 6534 default:
6535 gcc_unreachable ();
6536 }
5d723e54
FXC		 6537}
6538
6539
6de9cd9a
DN		 6540/****************** Constant simplification *****************/
6541
6542/* Master function to convert one constant to another. While this is
6543 used as a simplification function, it requires the destination type
6544 and kind information which is supplied by a special case in
6545 do_simplify(). */
6546
6547gfc_expr *
edf1eac2 6548gfc_convert_constant (gfc_expr *e, bt type, int kind)
6de9cd9a
DN		 6549{
6550 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
b7e75771 6551 gfc_constructor *c;
6de9cd9a
DN		 6552
6553 switch (e->ts.type)
6554 {
6555 case BT_INTEGER:
6556 switch (type)
6557 {
6558 case BT_INTEGER:
6559 f = gfc_int2int;
6560 break;
6561 case BT_REAL:
6562 f = gfc_int2real;
6563 break;
6564 case BT_COMPLEX:
6565 f = gfc_int2complex;
6566 break;
c3a29423
RS		 6567 case BT_LOGICAL:
6568 f = gfc_int2log;
6569 break;
6de9cd9a
DN		 6570 default:
6571 goto oops;
6572 }
6573 break;
6574
6575 case BT_REAL:
6576 switch (type)
6577 {
6578 case BT_INTEGER:
6579 f = gfc_real2int;
6580 break;
6581 case BT_REAL:
6582 f = gfc_real2real;
6583 break;
6584 case BT_COMPLEX:
6585 f = gfc_real2complex;
6586 break;
6587 default:
6588 goto oops;
6589 }
6590 break;
6591
6592 case BT_COMPLEX:
6593 switch (type)
6594 {
6595 case BT_INTEGER:
6596 f = gfc_complex2int;
6597 break;
6598 case BT_REAL:
6599 f = gfc_complex2real;
6600 break;
6601 case BT_COMPLEX:
6602 f = gfc_complex2complex;
6603 break;
6604
6605 default:
6606 goto oops;
6607 }
6608 break;
6609
6610 case BT_LOGICAL:
c3a29423
RS		 6611 switch (type)
6612 {
6613 case BT_INTEGER:
6614 f = gfc_log2int;
6615 break;
6616 case BT_LOGICAL:
6617 f = gfc_log2log;
6618 break;
6619 default:
6620 goto oops;
6621 }
6de9cd9a
DN		 6622 break;
6623
d3642f89
FW		 6624 case BT_HOLLERITH:
6625 switch (type)
6626 {
6627 case BT_INTEGER:
6628 f = gfc_hollerith2int;
6629 break;
6630
6631 case BT_REAL:
6632 f = gfc_hollerith2real;
6633 break;
6634
6635 case BT_COMPLEX:
6636 f = gfc_hollerith2complex;
6637 break;
6638
6639 case BT_CHARACTER:
6640 f = gfc_hollerith2character;
6641 break;
6642
6643 case BT_LOGICAL:
6644 f = gfc_hollerith2logical;
6645 break;
6646
6647 default:
6648 goto oops;
6649 }
6650 break;
6651
6de9cd9a
DN		 6652 default:
6653 oops:
6654 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
6655 }
6656
6657 result = NULL;
6658
6659 switch (e->expr_type)
6660 {
6661 case EXPR_CONSTANT:
6662 result = f (e, kind);
6663 if (result == NULL)
6664 return &gfc_bad_expr;
6665 break;
6666
6667 case EXPR_ARRAY:
6668 if (!gfc_is_constant_expr (e))
6669 break;
6670
b7e75771
JD		 6671 result = gfc_get_array_expr (type, kind, &e->where);
6672 result->shape = gfc_copy_shape (e->shape, e->rank);
6673 result->rank = e->rank;
6de9cd9a 6674
b7e75771
JD		 6675 for (c = gfc_constructor_first (e->value.constructor);
6676 c; c = gfc_constructor_next (c))
6de9cd9a 6677 {
b7e75771 6678 gfc_expr *tmp;
6de9cd9a 6679 if (c->iterator == NULL)
b7e75771 6680 tmp = f (c->expr, kind);
6de9cd9a
DN		 6681 else
6682 {
6683 g = gfc_convert_constant (c->expr, type, kind);
6684 if (g == &gfc_bad_expr)
b7e75771
JD		 6685 {
6686 gfc_free_expr (result);
6687 return g;
6688 }
6689 tmp = g;
6de9cd9a
DN		 6690 }
6691
b7e75771 6692 if (tmp == NULL)
6de9cd9a 6693 {
b7e75771 6694 gfc_free_expr (result);
6de9cd9a
DN		 6695 return NULL;
6696 }
b7e75771
JD		 6697
6698 gfc_constructor_append_expr (&result->value.constructor,
6699 tmp, &c->where);
6de9cd9a
DN		 6700 }
6701
6de9cd9a
DN		 6702 break;
6703
6704 default:
6705 break;
6706 }
6707
6708 return result;
6709}
d393bbd7
FXC		 6710
6711
6712/* Function for converting character constants. */
6713gfc_expr *
6714gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
6715{
6716 gfc_expr *result;
6717 int i;
6718
6719 if (!gfc_is_constant_expr (e))
6720 return NULL;
6721
691da334
FXC		 6722 if (e->expr_type == EXPR_CONSTANT)
6723 {
6724 /* Simple case of a scalar. */
b7e75771 6725 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
691da334 6726 if (result == NULL)
d393bbd7 6727 return &gfc_bad_expr;
d393bbd7 6728
691da334
FXC		 6729 result->value.character.length = e->value.character.length;
6730 result->value.character.string
6731 = gfc_get_wide_string (e->value.character.length + 1);
6732 memcpy (result->value.character.string, e->value.character.string,
6733 (e->value.character.length + 1) * sizeof (gfc_char_t));
6734
6735 /* Check we only have values representable in the destination kind. */
6736 for (i = 0; i < result->value.character.length; i++)
6737 if (!gfc_check_character_range (result->value.character.string[i],
6738 kind))
6739 {
6740 gfc_error ("Character '%s' in string at %L cannot be converted "
6741 "into character kind %d",
6742 gfc_print_wide_char (result->value.character.string[i]),
6743 &e->where, kind);
6744 return &gfc_bad_expr;
6745 }
6746
6747 return result;
6748 }
6749 else if (e->expr_type == EXPR_ARRAY)
6750 {
6751 /* For an array constructor, we convert each constructor element. */
b7e75771 6752 gfc_constructor *c;
691da334 6753
b7e75771
JD		 6754 result = gfc_get_array_expr (type, kind, &e->where);
6755 result->shape = gfc_copy_shape (e->shape, e->rank);
6756 result->rank = e->rank;
6757 result->ts.u.cl = e->ts.u.cl;
691da334 6758
b7e75771
JD		 6759 for (c = gfc_constructor_first (e->value.constructor);
6760 c; c = gfc_constructor_next (c))
6761 {
6762 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
6763 if (tmp == &gfc_bad_expr)
691da334 6764 {
b7e75771 6765 gfc_free_expr (result);
691da334
FXC		 6766 return &gfc_bad_expr;
6767 }
6768
b7e75771 6769 if (tmp == NULL)
691da334 6770 {
b7e75771 6771 gfc_free_expr (result);
691da334
FXC		 6772 return NULL;
6773 }
691da334 6774
b7e75771
JD		 6775 gfc_constructor_append_expr (&result->value.constructor,
6776 tmp, &c->where);
6777 }
691da334
FXC		 6778
6779 return result;
6780 }
6781 else
6782 return NULL;
d393bbd7 6783}
d000aa67
TB		 6784
6785
6786gfc_expr *
6787gfc_simplify_compiler_options (void)
6788{
41804a5b
TB		 6789 char *str;
6790 gfc_expr *result;
6791
6792 str = gfc_get_option_string ();
6793 result = gfc_get_character_expr (gfc_default_character_kind,
6794 &gfc_current_locus, str, strlen (str));
cede9502 6795 free (str);
41804a5b 6796 return result;
d000aa67
TB		 6797}
6798
6799
6800gfc_expr *
6801gfc_simplify_compiler_version (void)
6802{
41804a5b
TB		 6803 char *buffer;
6804 size_t len;
6805
ed17fc41
SK		 6806 len = strlen ("GCC version ") + strlen (version_string);
6807 buffer = XALLOCAVEC (char, len + 1);
6808 snprintf (buffer, len + 1, "GCC version %s", version_string);
d000aa67 6809 return gfc_get_character_expr (gfc_default_character_kind,
41804a5b 6810 &gfc_current_locus, buffer, len);
d000aa67 6811}
Mirror of https://gcc.gnu.org/git/gcc.git