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