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