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