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