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