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 340888 : range_check (gfc_expr *result, const char *name)
79 : {
80 340888 : if (result == NULL)
81 : return &gfc_bad_expr;
82 :
83 340888 : if (result->expr_type != EXPR_CONSTANT)
84 : return result;
85 :
86 340868 : 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 151578 : get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
121 : {
122 151578 : int kind;
123 :
124 151578 : 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 132601 : is_constant_array_expr (gfc_expr *e)
221 : {
222 132601 : gfc_constructor *c;
223 132601 : bool array_OK = true;
224 132601 : mpz_t size;
225 :
226 132601 : if (e == NULL)
227 : return true;
228 :
229 119372 : 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 119372 : if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
234 90578 : return false;
235 :
236 : /* A non-zero-sized constant array shall have a non-empty constructor. */
237 28794 : 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 28791 : for (c = gfc_constructor_first (e->value.constructor);
249 508118 : c; c = gfc_constructor_next (c))
250 479350 : 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 28791 : bool expand;
260 57582 : expand = (e->rank == 1
261 27848 : && e->shape
262 56628 : && (mpz_cmp_ui (e->shape[0], flag_max_array_constructor) < 0));
263 :
264 28791 : 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 169065 : gfc_is_size_zero_array (gfc_expr *array)
304 : {
305 :
306 169065 : if (array->rank == 0)
307 : return false;
308 :
309 163981 : 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 153586 : if (array->expr_type == EXPR_ARRAY)
321 98616 : 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 3991 : init_result_expr (gfc_expr *e, int init, gfc_expr *array)
331 : {
332 3991 : 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 3766 : else if (e && e->expr_type == EXPR_CONSTANT)
342 : {
343 3766 : int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
344 3766 : HOST_WIDE_INT length;
345 3766 : gfc_char_t *string;
346 :
347 3766 : switch (e->ts.type)
348 : {
349 2185 : case BT_LOGICAL:
350 2185 : e->value.logical = (init ? 1 : 0);
351 2185 : break;
352 :
353 1023 : case BT_INTEGER:
354 1023 : if (init == INT_MIN)
355 144 : mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
356 879 : else if (init == INT_MAX)
357 158 : mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
358 : else
359 721 : 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 3766 : }
417 : else
418 0 : gcc_unreachable();
419 3991 : }
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 3193 : transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
493 : int kind, locus* where)
494 : {
495 3193 : gfc_expr *result;
496 3193 : int i, nelem;
497 :
498 3193 : if (!dim || array->rank == 1)
499 2968 : 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 2552 : simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
558 : transformational_op op)
559 : {
560 2552 : gfc_expr *a, *m;
561 2552 : gfc_constructor *array_ctor, *mask_ctor;
562 :
563 : /* Shortcut for constant .FALSE. MASK. */
564 2552 : if (mask
565 98 : && mask->expr_type == EXPR_CONSTANT
566 24 : && !mask->value.logical)
567 : return result;
568 :
569 2528 : array_ctor = gfc_constructor_first (array->value.constructor);
570 2528 : mask_ctor = NULL;
571 2528 : if (mask && mask->expr_type == EXPR_ARRAY)
572 74 : mask_ctor = gfc_constructor_first (mask->value.constructor);
573 :
574 71111 : while (array_ctor)
575 : {
576 68583 : a = array_ctor->expr;
577 68583 : array_ctor = gfc_constructor_next (array_ctor);
578 :
579 : /* A constant MASK equals .TRUE. here and can be ignored. */
580 68583 : 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 68279 : result = op (result, gfc_copy_expr (a));
589 68279 : 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 57652 : simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
746 : int init_val, transformational_op op)
747 : {
748 57652 : gfc_expr *result;
749 57652 : bool size_zero;
750 :
751 57652 : size_zero = gfc_is_size_zero_array (array);
752 :
753 112258 : if (!(is_constant_array_expr (array) || size_zero)
754 3046 : || array->shape == NULL
755 60691 : || !gfc_is_constant_expr (dim))
756 54613 : return NULL;
757 :
758 3039 : if (mask
759 242 : && !is_constant_array_expr (mask)
760 3221 : && mask->expr_type != EXPR_CONSTANT)
761 : return NULL;
762 :
763 2881 : result = transformational_result (array, dim, array->ts.type,
764 : array->ts.kind, &array->where);
765 2881 : init_result_expr (result, init_val, array);
766 :
767 2881 : if (size_zero)
768 : return result;
769 :
770 2634 : return !dim || array->rank == 1 ?
771 2491 : simplify_transformation_to_scalar (result, array, mask, op) :
772 2634 : simplify_transformation_to_array (result, array, dim, mask, op, NULL);
773 : }
774 :
775 :
776 : /********************** Simplification functions *****************************/
777 :
778 : gfc_expr *
779 25284 : gfc_simplify_abs (gfc_expr *e)
780 : {
781 25284 : gfc_expr *result;
782 :
783 25284 : 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 22170 : simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
812 : {
813 22170 : gfc_expr *result;
814 22170 : int kind;
815 22170 : bool too_large = false;
816 :
817 22170 : if (e->expr_type != EXPR_CONSTANT)
818 : return NULL;
819 :
820 14561 : kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
821 14561 : if (kind == -1)
822 : return &gfc_bad_expr;
823 :
824 14561 : 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 14553 : 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 14553 : if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
837 : too_large = true;
838 14544 : 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 14542 : result = gfc_get_character_expr (kind, &e->where, NULL, 1);
857 14542 : result->value.character.string[0] = mpz_get_ui (e->value.integer);
858 :
859 14542 : 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 43007 : gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
1132 : {
1133 43007 : 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 8842 : gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1848 : {
1849 8842 : 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 918 : gfc_simplify_cos (gfc_expr *x)
1989 : {
1990 918 : gfc_expr *result;
1991 :
1992 918 : 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 40 : sstride[0] = 0;
3008 :
3009 40 : n = 0;
3010 110 : for (d=0; d < array->rank; d++)
3011 : {
3012 70 : if (d == which)
3013 : {
3014 40 : rsoffset = a_stride[d];
3015 40 : len = a_extent[d];
3016 : }
3017 : else
3018 : {
3019 30 : count[n] = 0;
3020 30 : extent[n] = a_extent[d];
3021 30 : sstride[n] = a_stride[d];
3022 30 : ss_ex[n] = sstride[n] * extent[n];
3023 30 : n++;
3024 : }
3025 : }
3026 40 : ss_ex[n] = 0;
3027 :
3028 40 : continue_loop = true;
3029 40 : d = array->rank;
3030 40 : rptr = resultvec;
3031 40 : sptr = arrayvec;
3032 :
3033 172 : while (continue_loop)
3034 : {
3035 132 : ssize_t sh, delta;
3036 :
3037 132 : if (shift_ctor)
3038 60 : sh = mpz_get_si (shift_ctor->expr->value.integer);
3039 : else
3040 : sh = shift_val;
3041 :
3042 132 : if (( sh >= 0 ? sh : -sh ) > len)
3043 : {
3044 : delta = len;
3045 : sh = len;
3046 : }
3047 : else
3048 118 : delta = (sh >= 0) ? sh: -sh;
3049 :
3050 132 : if (sh > 0)
3051 : {
3052 81 : src = &sptr[delta * rsoffset];
3053 81 : dest = rptr;
3054 : }
3055 : else
3056 : {
3057 51 : src = sptr;
3058 51 : dest = &rptr[delta * rsoffset];
3059 : }
3060 :
3061 387 : for (n = 0; n < len - delta; n++)
3062 : {
3063 255 : *dest = *src;
3064 255 : dest += rsoffset;
3065 255 : src += rsoffset;
3066 : }
3067 :
3068 132 : if (sh < 0)
3069 45 : dest = rptr;
3070 :
3071 132 : n = delta;
3072 :
3073 132 : if (bnd_ctor)
3074 : {
3075 73 : while (n--)
3076 : {
3077 47 : *dest = bnd_ctor->expr;
3078 47 : dest += rsoffset;
3079 : }
3080 : }
3081 : else
3082 : {
3083 260 : while (n--)
3084 : {
3085 154 : *dest = bnd;
3086 154 : dest += rsoffset;
3087 : }
3088 : }
3089 132 : rptr += sstride[0];
3090 132 : sptr += sstride[0];
3091 132 : if (shift_ctor)
3092 60 : shift_ctor = gfc_constructor_next (shift_ctor);
3093 :
3094 132 : if (bnd_ctor)
3095 26 : bnd_ctor = gfc_constructor_next (bnd_ctor);
3096 :
3097 132 : count[0]++;
3098 132 : n = 0;
3099 155 : while (count[n] == extent[n])
3100 : {
3101 63 : count[n] = 0;
3102 63 : rptr -= ss_ex[n];
3103 63 : sptr -= ss_ex[n];
3104 63 : n++;
3105 63 : if (n >= d - 1)
3106 : {
3107 : continue_loop = false;
3108 : break;
3109 : }
3110 : else
3111 : {
3112 23 : count[n]++;
3113 23 : rptr += sstride[n];
3114 23 : sptr += sstride[n];
3115 : }
3116 : }
3117 : }
3118 :
3119 496 : for (i = 0; i < arraysize; i++)
3120 : {
3121 456 : gfc_constructor_append_expr (&result->value.constructor,
3122 456 : gfc_copy_expr (resultvec[i]),
3123 : NULL);
3124 : }
3125 :
3126 40 : free (arrayvec);
3127 40 : free (resultvec);
3128 :
3129 42 : final:
3130 42 : if (temp_boundary)
3131 29 : gfc_free_expr (bnd);
3132 :
3133 : return result;
3134 : }
3135 :
3136 : gfc_expr *
3137 169 : gfc_simplify_erf (gfc_expr *x)
3138 : {
3139 169 : gfc_expr *result;
3140 :
3141 169 : if (x->expr_type != EXPR_CONSTANT)
3142 : return NULL;
3143 :
3144 35 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3145 35 : mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
3146 :
3147 35 : return range_check (result, "ERF");
3148 : }
3149 :
3150 :
3151 : gfc_expr *
3152 242 : gfc_simplify_erfc (gfc_expr *x)
3153 : {
3154 242 : gfc_expr *result;
3155 :
3156 242 : if (x->expr_type != EXPR_CONSTANT)
3157 : return NULL;
3158 :
3159 36 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3160 36 : mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
3161 :
3162 36 : return range_check (result, "ERFC");
3163 : }
3164 :
3165 :
3166 : /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
3167 :
3168 : #define MAX_ITER 200
3169 : #define ARG_LIMIT 12
3170 :
3171 : /* Calculate ERFC_SCALED directly by its definition:
3172 :
3173 : ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
3174 :
3175 : using a large precision for intermediate results. This is used for all
3176 : but large values of the argument. */
3177 : static void
3178 39 : fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
3179 : {
3180 39 : mpfr_prec_t prec;
3181 39 : mpfr_t a, b;
3182 :
3183 39 : prec = mpfr_get_default_prec ();
3184 39 : mpfr_set_default_prec (10 * prec);
3185 :
3186 39 : mpfr_init (a);
3187 39 : mpfr_init (b);
3188 :
3189 39 : mpfr_set (a, arg, GFC_RND_MODE);
3190 39 : mpfr_sqr (b, a, GFC_RND_MODE);
3191 39 : mpfr_exp (b, b, GFC_RND_MODE);
3192 39 : mpfr_erfc (a, a, GFC_RND_MODE);
3193 39 : mpfr_mul (a, a, b, GFC_RND_MODE);
3194 :
3195 39 : mpfr_set (res, a, GFC_RND_MODE);
3196 39 : mpfr_set_default_prec (prec);
3197 :
3198 39 : mpfr_clear (a);
3199 39 : mpfr_clear (b);
3200 39 : }
3201 :
3202 : /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
3203 :
3204 : ERFC_SCALED(x) = 1 / (x * sqrt(pi))
3205 : * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
3206 : / (2 * x**2)**n)
3207 :
3208 : This is used for large values of the argument. Intermediate calculations
3209 : are performed with twice the precision. We don't do a fixed number of
3210 : iterations of the sum, but stop when it has converged to the required
3211 : precision. */
3212 : static void
3213 10 : asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
3214 : {
3215 10 : mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
3216 10 : mpz_t num;
3217 10 : mpfr_prec_t prec;
3218 10 : unsigned i;
3219 :
3220 10 : prec = mpfr_get_default_prec ();
3221 10 : mpfr_set_default_prec (2 * prec);
3222 :
3223 10 : mpfr_init (sum);
3224 10 : mpfr_init (x);
3225 10 : mpfr_init (u);
3226 10 : mpfr_init (v);
3227 10 : mpfr_init (w);
3228 10 : mpz_init (num);
3229 :
3230 10 : mpfr_init (oldsum);
3231 10 : mpfr_init (sumtrunc);
3232 10 : mpfr_set_prec (oldsum, prec);
3233 10 : mpfr_set_prec (sumtrunc, prec);
3234 :
3235 10 : mpfr_set (x, arg, GFC_RND_MODE);
3236 10 : mpfr_set_ui (sum, 1, GFC_RND_MODE);
3237 10 : mpz_set_ui (num, 1);
3238 :
3239 10 : mpfr_set (u, x, GFC_RND_MODE);
3240 10 : mpfr_sqr (u, u, GFC_RND_MODE);
3241 10 : mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
3242 10 : mpfr_pow_si (u, u, -1, GFC_RND_MODE);
3243 :
3244 132 : for (i = 1; i < MAX_ITER; i++)
3245 : {
3246 132 : mpfr_set (oldsum, sum, GFC_RND_MODE);
3247 :
3248 132 : mpz_mul_ui (num, num, 2 * i - 1);
3249 132 : mpz_neg (num, num);
3250 :
3251 132 : mpfr_set (w, u, GFC_RND_MODE);
3252 132 : mpfr_pow_ui (w, w, i, GFC_RND_MODE);
3253 :
3254 132 : mpfr_set_z (v, num, GFC_RND_MODE);
3255 132 : mpfr_mul (v, v, w, GFC_RND_MODE);
3256 :
3257 132 : mpfr_add (sum, sum, v, GFC_RND_MODE);
3258 :
3259 132 : mpfr_set (sumtrunc, sum, GFC_RND_MODE);
3260 132 : if (mpfr_cmp (sumtrunc, oldsum) == 0)
3261 : break;
3262 : }
3263 :
3264 : /* We should have converged by now; otherwise, ARG_LIMIT is probably
3265 : set too low. */
3266 10 : gcc_assert (i < MAX_ITER);
3267 :
3268 : /* Divide by x * sqrt(Pi). */
3269 10 : mpfr_const_pi (u, GFC_RND_MODE);
3270 10 : mpfr_sqrt (u, u, GFC_RND_MODE);
3271 10 : mpfr_mul (u, u, x, GFC_RND_MODE);
3272 10 : mpfr_div (sum, sum, u, GFC_RND_MODE);
3273 :
3274 10 : mpfr_set (res, sum, GFC_RND_MODE);
3275 10 : mpfr_set_default_prec (prec);
3276 :
3277 10 : mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
3278 10 : mpz_clear (num);
3279 10 : }
3280 :
3281 :
3282 : gfc_expr *
3283 143 : gfc_simplify_erfc_scaled (gfc_expr *x)
3284 : {
3285 143 : gfc_expr *result;
3286 :
3287 143 : if (x->expr_type != EXPR_CONSTANT)
3288 : return NULL;
3289 :
3290 49 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3291 49 : if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
3292 10 : asympt_erfc_scaled (result->value.real, x->value.real);
3293 : else
3294 39 : fullprec_erfc_scaled (result->value.real, x->value.real);
3295 :
3296 49 : return range_check (result, "ERFC_SCALED");
3297 : }
3298 :
3299 : #undef MAX_ITER
3300 : #undef ARG_LIMIT
3301 :
3302 :
3303 : gfc_expr *
3304 3629 : gfc_simplify_epsilon (gfc_expr *e)
3305 : {
3306 3629 : gfc_expr *result;
3307 3629 : int i;
3308 :
3309 3629 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3310 :
3311 3629 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
3312 3629 : mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
3313 :
3314 3629 : return range_check (result, "EPSILON");
3315 : }
3316 :
3317 :
3318 : gfc_expr *
3319 1222 : gfc_simplify_exp (gfc_expr *x)
3320 : {
3321 1222 : gfc_expr *result;
3322 :
3323 1222 : if (x->expr_type != EXPR_CONSTANT)
3324 : return NULL;
3325 :
3326 151 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3327 :
3328 151 : switch (x->ts.type)
3329 : {
3330 88 : case BT_REAL:
3331 88 : mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
3332 88 : break;
3333 :
3334 63 : case BT_COMPLEX:
3335 63 : gfc_set_model_kind (x->ts.kind);
3336 63 : mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
3337 63 : break;
3338 :
3339 0 : default:
3340 0 : gfc_internal_error ("in gfc_simplify_exp(): Bad type");
3341 : }
3342 :
3343 151 : return range_check (result, "EXP");
3344 : }
3345 :
3346 :
3347 : gfc_expr *
3348 1020 : gfc_simplify_exponent (gfc_expr *x)
3349 : {
3350 1020 : long int val;
3351 1020 : gfc_expr *result;
3352 :
3353 1020 : if (x->expr_type != EXPR_CONSTANT)
3354 : return NULL;
3355 :
3356 150 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3357 : &x->where);
3358 :
3359 : /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
3360 150 : if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real))
3361 : {
3362 18 : int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
3363 18 : mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
3364 18 : return result;
3365 : }
3366 :
3367 : /* EXPONENT(+/- 0.0) = 0 */
3368 132 : if (mpfr_zero_p (x->value.real))
3369 : {
3370 12 : mpz_set_ui (result->value.integer, 0);
3371 12 : return result;
3372 : }
3373 :
3374 120 : gfc_set_model (x->value.real);
3375 :
3376 120 : val = (long int) mpfr_get_exp (x->value.real);
3377 120 : mpz_set_si (result->value.integer, val);
3378 :
3379 120 : return range_check (result, "EXPONENT");
3380 : }
3381 :
3382 :
3383 : gfc_expr *
3384 122 : gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED,
3385 : gfc_expr *kind)
3386 : {
3387 122 : if (flag_coarray == GFC_FCOARRAY_NONE)
3388 : {
3389 0 : gfc_current_locus = *gfc_current_intrinsic_where;
3390 0 : gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3391 : return &gfc_bad_expr;
3392 : }
3393 :
3394 122 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
3395 : {
3396 22 : gfc_expr *result;
3397 22 : int actual_kind;
3398 22 : if (kind)
3399 10 : gfc_extract_int (kind, &actual_kind);
3400 : else
3401 12 : actual_kind = gfc_default_integer_kind;
3402 :
3403 22 : result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus);
3404 22 : result->rank = 1;
3405 22 : return result;
3406 : }
3407 :
3408 : /* For fcoarray = lib no simplification is possible, because it is not known
3409 : what images failed or are stopped at compile time. */
3410 : return NULL;
3411 : }
3412 :
3413 :
3414 : gfc_expr *
3415 34 : gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED)
3416 : {
3417 34 : if (flag_coarray == GFC_FCOARRAY_NONE)
3418 : {
3419 0 : gfc_current_locus = *gfc_current_intrinsic_where;
3420 0 : gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3421 : return &gfc_bad_expr;
3422 : }
3423 :
3424 34 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
3425 : {
3426 9 : gfc_expr *result;
3427 9 : result = gfc_get_null_expr (&gfc_current_locus);
3428 9 : result->ts.type = BT_DERIVED;
3429 9 : gfc_find_symbol ("team_type", gfc_current_ns, 1, &result->ts.u.derived);
3430 :
3431 9 : return result;
3432 : }
3433 :
3434 : /* For fcoarray = lib no simplification is possible, because it is not known
3435 : what images failed or are stopped at compile time. */
3436 : return NULL;
3437 : }
3438 :
3439 :
3440 : gfc_expr *
3441 865 : gfc_simplify_float (gfc_expr *a)
3442 : {
3443 865 : gfc_expr *result;
3444 :
3445 865 : if (a->expr_type != EXPR_CONSTANT)
3446 : return NULL;
3447 :
3448 493 : result = gfc_int2real (a, gfc_default_real_kind);
3449 :
3450 493 : return range_check (result, "FLOAT");
3451 : }
3452 :
3453 :
3454 : static bool
3455 2408 : is_last_ref_vtab (gfc_expr *e)
3456 : {
3457 2408 : gfc_ref *ref;
3458 2408 : gfc_component *comp = NULL;
3459 :
3460 2408 : if (e->expr_type != EXPR_VARIABLE)
3461 : return false;
3462 :
3463 3448 : for (ref = e->ref; ref; ref = ref->next)
3464 1058 : if (ref->type == REF_COMPONENT)
3465 444 : comp = ref->u.c.component;
3466 :
3467 2390 : if (!e->ref || !comp)
3468 1970 : return e->symtree->n.sym->attr.vtab;
3469 :
3470 420 : if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
3471 147 : return true;
3472 :
3473 : return false;
3474 : }
3475 :
3476 :
3477 : gfc_expr *
3478 542 : gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
3479 : {
3480 : /* Avoid simplification of resolved symbols. */
3481 542 : if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
3482 : return NULL;
3483 :
3484 324 : if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
3485 27 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3486 27 : gfc_type_is_extension_of (mold->ts.u.derived,
3487 54 : a->ts.u.derived));
3488 :
3489 297 : if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
3490 : return NULL;
3491 :
3492 105 : if ((a->ts.type == BT_CLASS && !gfc_expr_attr (a).class_ok)
3493 239 : || (mold->ts.type == BT_CLASS && !gfc_expr_attr (mold).class_ok))
3494 4 : return NULL;
3495 :
3496 : /* Return .false. if the dynamic type can never be an extension. */
3497 104 : if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
3498 40 : && !gfc_type_is_extension_of
3499 40 : (CLASS_DATA (mold)->ts.u.derived,
3500 40 : CLASS_DATA (a)->ts.u.derived)
3501 5 : && !gfc_type_is_extension_of
3502 5 : (CLASS_DATA (a)->ts.u.derived,
3503 5 : CLASS_DATA (mold)->ts.u.derived))
3504 127 : || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
3505 27 : && !gfc_type_is_extension_of
3506 27 : (CLASS_DATA (mold)->ts.u.derived,
3507 27 : a->ts.u.derived))
3508 253 : || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3509 64 : && !gfc_type_is_extension_of
3510 64 : (mold->ts.u.derived,
3511 64 : CLASS_DATA (a)->ts.u.derived)
3512 19 : && !gfc_type_is_extension_of
3513 19 : (CLASS_DATA (a)->ts.u.derived,
3514 19 : mold->ts.u.derived)))
3515 13 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3516 :
3517 : /* Return .true. if the dynamic type is guaranteed to be an extension. */
3518 96 : if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3519 178 : && gfc_type_is_extension_of (mold->ts.u.derived,
3520 60 : CLASS_DATA (a)->ts.u.derived))
3521 45 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
3522 :
3523 : return NULL;
3524 : }
3525 :
3526 :
3527 : gfc_expr *
3528 771 : gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
3529 : {
3530 : /* Avoid simplification of resolved symbols. */
3531 771 : if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
3532 : return NULL;
3533 :
3534 : /* Return .false. if the dynamic type can never be the
3535 : same. */
3536 669 : if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok)
3537 103 : || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok))
3538 752 : && !gfc_type_compatible (&a->ts, &b->ts)
3539 813 : && !gfc_type_compatible (&b->ts, &a->ts))
3540 6 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3541 :
3542 765 : if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
3543 : return NULL;
3544 :
3545 18 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3546 18 : gfc_compare_derived_types (a->ts.u.derived,
3547 36 : b->ts.u.derived));
3548 : }
3549 :
3550 :
3551 : gfc_expr *
3552 414 : gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
3553 : {
3554 414 : gfc_expr *result;
3555 414 : mpfr_t floor;
3556 414 : int kind;
3557 :
3558 414 : kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
3559 414 : if (kind == -1)
3560 0 : gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3561 :
3562 414 : if (e->expr_type != EXPR_CONSTANT)
3563 : return NULL;
3564 :
3565 28 : mpfr_init2 (floor, mpfr_get_prec (e->value.real));
3566 28 : mpfr_floor (floor, e->value.real);
3567 :
3568 28 : result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
3569 28 : gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
3570 :
3571 28 : mpfr_clear (floor);
3572 :
3573 28 : return range_check (result, "FLOOR");
3574 : }
3575 :
3576 :
3577 : gfc_expr *
3578 264 : gfc_simplify_fraction (gfc_expr *x)
3579 : {
3580 264 : gfc_expr *result;
3581 264 : mpfr_exp_t e;
3582 :
3583 264 : if (x->expr_type != EXPR_CONSTANT)
3584 : return NULL;
3585 :
3586 84 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
3587 :
3588 : /* FRACTION(inf) = NaN. */
3589 84 : if (mpfr_inf_p (x->value.real))
3590 : {
3591 12 : mpfr_set_nan (result->value.real);
3592 12 : return result;
3593 : }
3594 :
3595 : /* mpfr_frexp() correctly handles zeros and NaNs. */
3596 72 : mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE);
3597 :
3598 72 : return range_check (result, "FRACTION");
3599 : }
3600 :
3601 :
3602 : gfc_expr *
3603 204 : gfc_simplify_gamma (gfc_expr *x)
3604 : {
3605 204 : gfc_expr *result;
3606 :
3607 204 : if (x->expr_type != EXPR_CONSTANT)
3608 : return NULL;
3609 :
3610 54 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3611 54 : mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
3612 :
3613 54 : return range_check (result, "GAMMA");
3614 : }
3615 :
3616 :
3617 : gfc_expr *
3618 6060 : gfc_simplify_huge (gfc_expr *e)
3619 : {
3620 6060 : gfc_expr *result;
3621 6060 : int i;
3622 :
3623 6060 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3624 6060 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3625 :
3626 6060 : switch (e->ts.type)
3627 : {
3628 4596 : case BT_INTEGER:
3629 4596 : mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
3630 4596 : break;
3631 :
3632 156 : case BT_UNSIGNED:
3633 156 : mpz_set (result->value.integer, gfc_unsigned_kinds[i].huge);
3634 156 : break;
3635 :
3636 1308 : case BT_REAL:
3637 1308 : mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
3638 1308 : break;
3639 :
3640 0 : default:
3641 0 : gcc_unreachable ();
3642 : }
3643 :
3644 6060 : return result;
3645 : }
3646 :
3647 :
3648 : gfc_expr *
3649 36 : gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
3650 : {
3651 36 : gfc_expr *result;
3652 :
3653 36 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3654 : return NULL;
3655 :
3656 12 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3657 12 : mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
3658 12 : return range_check (result, "HYPOT");
3659 : }
3660 :
3661 :
3662 : /* We use the processor's collating sequence, because all
3663 : systems that gfortran currently works on are ASCII. */
3664 :
3665 : gfc_expr *
3666 9879 : gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
3667 : {
3668 9879 : gfc_expr *result;
3669 9879 : gfc_char_t index;
3670 9879 : int k;
3671 :
3672 9879 : if (e->expr_type != EXPR_CONSTANT)
3673 : return NULL;
3674 :
3675 4965 : if (e->value.character.length != 1)
3676 : {
3677 0 : gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
3678 0 : return &gfc_bad_expr;
3679 : }
3680 :
3681 4965 : index = e->value.character.string[0];
3682 :
3683 4965 : if (warn_surprising && index > 127)
3684 1 : gfc_warning (OPT_Wsurprising,
3685 : "Argument of IACHAR function at %L outside of range 0..127",
3686 : &e->where);
3687 :
3688 4965 : k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
3689 4965 : if (k == -1)
3690 : return &gfc_bad_expr;
3691 :
3692 4965 : result = gfc_get_int_expr (k, &e->where, index);
3693 :
3694 4965 : return range_check (result, "IACHAR");
3695 : }
3696 :
3697 :
3698 : static gfc_expr *
3699 96 : do_bit_and (gfc_expr *result, gfc_expr *e)
3700 : {
3701 96 : if (flag_unsigned)
3702 : {
3703 72 : gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
3704 : && e->expr_type == EXPR_CONSTANT);
3705 72 : gcc_assert ((result->ts.type == BT_INTEGER
3706 : || result->ts.type == BT_UNSIGNED)
3707 : && result->expr_type == EXPR_CONSTANT);
3708 : }
3709 : else
3710 : {
3711 24 : gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3712 24 : gcc_assert (result->ts.type == BT_INTEGER
3713 : && result->expr_type == EXPR_CONSTANT);
3714 : }
3715 :
3716 96 : mpz_and (result->value.integer, result->value.integer, e->value.integer);
3717 96 : return result;
3718 : }
3719 :
3720 :
3721 : gfc_expr *
3722 217 : gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3723 : {
3724 217 : return simplify_transformation (array, dim, mask, -1, do_bit_and);
3725 : }
3726 :
3727 :
3728 : static gfc_expr *
3729 96 : do_bit_ior (gfc_expr *result, gfc_expr *e)
3730 : {
3731 96 : if (flag_unsigned)
3732 : {
3733 72 : gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
3734 : && e->expr_type == EXPR_CONSTANT);
3735 72 : gcc_assert ((result->ts.type == BT_INTEGER
3736 : || result->ts.type == BT_UNSIGNED)
3737 : && result->expr_type == EXPR_CONSTANT);
3738 : }
3739 : else
3740 : {
3741 24 : gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3742 24 : gcc_assert (result->ts.type == BT_INTEGER
3743 : && result->expr_type == EXPR_CONSTANT);
3744 : }
3745 :
3746 96 : mpz_ior (result->value.integer, result->value.integer, e->value.integer);
3747 96 : return result;
3748 : }
3749 :
3750 :
3751 : gfc_expr *
3752 169 : gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3753 : {
3754 169 : return simplify_transformation (array, dim, mask, 0, do_bit_ior);
3755 : }
3756 :
3757 :
3758 : gfc_expr *
3759 1875 : gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
3760 : {
3761 1875 : gfc_expr *result;
3762 1875 : bt type;
3763 :
3764 1875 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3765 : return NULL;
3766 :
3767 269 : type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER;
3768 269 : result = gfc_get_constant_expr (type, x->ts.kind, &x->where);
3769 269 : mpz_and (result->value.integer, x->value.integer, y->value.integer);
3770 :
3771 269 : return range_check (result, "IAND");
3772 : }
3773 :
3774 :
3775 : gfc_expr *
3776 448 : gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
3777 : {
3778 448 : gfc_expr *result;
3779 448 : int k, pos;
3780 :
3781 448 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3782 : return NULL;
3783 :
3784 66 : if (!gfc_check_bitfcn (x, y))
3785 : return &gfc_bad_expr;
3786 :
3787 58 : gfc_extract_int (y, &pos);
3788 :
3789 58 : k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3790 :
3791 58 : result = gfc_copy_expr (x);
3792 : /* Drop any separate memory representation of x to avoid potential
3793 : inconsistencies in result. */
3794 58 : if (result->representation.string)
3795 : {
3796 12 : free (result->representation.string);
3797 12 : result->representation.string = NULL;
3798 : }
3799 :
3800 58 : if (x->ts.type == BT_INTEGER)
3801 : {
3802 52 : gfc_convert_mpz_to_unsigned (result->value.integer,
3803 : gfc_integer_kinds[k].bit_size);
3804 :
3805 52 : mpz_clrbit (result->value.integer, pos);
3806 :
3807 52 : gfc_convert_mpz_to_signed (result->value.integer,
3808 : gfc_integer_kinds[k].bit_size);
3809 : }
3810 : else
3811 6 : mpz_clrbit (result->value.integer, pos);
3812 :
3813 : return result;
3814 : }
3815 :
3816 :
3817 : gfc_expr *
3818 106 : gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
3819 : {
3820 106 : gfc_expr *result;
3821 106 : int pos, len;
3822 106 : int i, k, bitsize;
3823 106 : int *bits;
3824 :
3825 106 : if (x->expr_type != EXPR_CONSTANT
3826 43 : || y->expr_type != EXPR_CONSTANT
3827 33 : || z->expr_type != EXPR_CONSTANT)
3828 : return NULL;
3829 :
3830 28 : if (!gfc_check_ibits (x, y, z))
3831 : return &gfc_bad_expr;
3832 :
3833 16 : gfc_extract_int (y, &pos);
3834 16 : gfc_extract_int (z, &len);
3835 :
3836 16 : k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3837 :
3838 16 : if (x->ts.type == BT_INTEGER)
3839 10 : bitsize = gfc_integer_kinds[k].bit_size;
3840 : else
3841 6 : bitsize = gfc_unsigned_kinds[k].bit_size;
3842 :
3843 :
3844 16 : if (pos + len > bitsize)
3845 : {
3846 0 : gfc_error ("Sum of second and third arguments of IBITS exceeds "
3847 : "bit size at %L", &y->where);
3848 0 : return &gfc_bad_expr;
3849 : }
3850 :
3851 16 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3852 :
3853 16 : if (x->ts.type == BT_INTEGER)
3854 10 : gfc_convert_mpz_to_unsigned (result->value.integer,
3855 : gfc_integer_kinds[k].bit_size);
3856 :
3857 16 : bits = XCNEWVEC (int, bitsize);
3858 :
3859 576 : for (i = 0; i < bitsize; i++)
3860 544 : bits[i] = 0;
3861 :
3862 60 : for (i = 0; i < len; i++)
3863 44 : bits[i] = mpz_tstbit (x->value.integer, i + pos);
3864 :
3865 560 : for (i = 0; i < bitsize; i++)
3866 : {
3867 544 : if (bits[i] == 0)
3868 544 : mpz_clrbit (result->value.integer, i);
3869 0 : else if (bits[i] == 1)
3870 0 : mpz_setbit (result->value.integer, i);
3871 : else
3872 0 : gfc_internal_error ("IBITS: Bad bit");
3873 : }
3874 :
3875 16 : free (bits);
3876 :
3877 16 : if (x->ts.type == BT_INTEGER)
3878 10 : gfc_convert_mpz_to_signed (result->value.integer,
3879 : gfc_integer_kinds[k].bit_size);
3880 :
3881 : return result;
3882 : }
3883 :
3884 :
3885 : gfc_expr *
3886 394 : gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
3887 : {
3888 394 : gfc_expr *result;
3889 394 : int k, pos;
3890 :
3891 394 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3892 : return NULL;
3893 :
3894 72 : if (!gfc_check_bitfcn (x, y))
3895 : return &gfc_bad_expr;
3896 :
3897 64 : gfc_extract_int (y, &pos);
3898 :
3899 64 : k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3900 :
3901 64 : result = gfc_copy_expr (x);
3902 : /* Drop any separate memory representation of x to avoid potential
3903 : inconsistencies in result. */
3904 64 : if (result->representation.string)
3905 : {
3906 12 : free (result->representation.string);
3907 12 : result->representation.string = NULL;
3908 : }
3909 :
3910 64 : if (x->ts.type == BT_INTEGER)
3911 : {
3912 58 : gfc_convert_mpz_to_unsigned (result->value.integer,
3913 : gfc_integer_kinds[k].bit_size);
3914 :
3915 58 : mpz_setbit (result->value.integer, pos);
3916 :
3917 58 : gfc_convert_mpz_to_signed (result->value.integer,
3918 : gfc_integer_kinds[k].bit_size);
3919 : }
3920 : else
3921 6 : mpz_setbit (result->value.integer, pos);
3922 :
3923 : return result;
3924 : }
3925 :
3926 :
3927 : gfc_expr *
3928 3667 : gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
3929 : {
3930 3667 : gfc_expr *result;
3931 3667 : gfc_char_t index;
3932 3667 : int k;
3933 :
3934 3667 : if (e->expr_type != EXPR_CONSTANT)
3935 : return NULL;
3936 :
3937 1957 : if (e->value.character.length != 1)
3938 : {
3939 2 : gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
3940 2 : return &gfc_bad_expr;
3941 : }
3942 :
3943 1955 : index = e->value.character.string[0];
3944 :
3945 1955 : k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
3946 1955 : if (k == -1)
3947 : return &gfc_bad_expr;
3948 :
3949 1955 : result = gfc_get_int_expr (k, &e->where, index);
3950 :
3951 1955 : return range_check (result, "ICHAR");
3952 : }
3953 :
3954 :
3955 : gfc_expr *
3956 1938 : gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
3957 : {
3958 1938 : gfc_expr *result;
3959 1938 : bt type;
3960 :
3961 1938 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3962 : return NULL;
3963 :
3964 155 : type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER;
3965 155 : result = gfc_get_constant_expr (type, x->ts.kind, &x->where);
3966 155 : mpz_xor (result->value.integer, x->value.integer, y->value.integer);
3967 :
3968 155 : return range_check (result, "IEOR");
3969 : }
3970 :
3971 :
3972 : gfc_expr *
3973 1340 : gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
3974 : {
3975 1340 : gfc_expr *result;
3976 1340 : bool back;
3977 1340 : HOST_WIDE_INT len, lensub, start, last, i, index = 0;
3978 1340 : int k, delta;
3979 :
3980 1340 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
3981 332 : || ( b != NULL && b->expr_type != EXPR_CONSTANT))
3982 : return NULL;
3983 :
3984 206 : back = (b != NULL && b->value.logical != 0);
3985 :
3986 274 : k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
3987 274 : if (k == -1)
3988 : return &gfc_bad_expr;
3989 :
3990 274 : result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
3991 :
3992 274 : len = x->value.character.length;
3993 274 : lensub = y->value.character.length;
3994 :
3995 274 : if (len < lensub)
3996 : {
3997 12 : mpz_set_si (result->value.integer, 0);
3998 12 : return result;
3999 : }
4000 :
4001 262 : if (lensub == 0)
4002 : {
4003 24 : if (back)
4004 12 : index = len + 1;
4005 : else
4006 : index = 1;
4007 24 : goto done;
4008 : }
4009 :
4010 238 : if (!back)
4011 : {
4012 126 : last = len + 1 - lensub;
4013 126 : start = 0;
4014 126 : delta = 1;
4015 : }
4016 : else
4017 : {
4018 112 : last = -1;
4019 112 : start = len - lensub;
4020 112 : delta = -1;
4021 : }
4022 :
4023 1210 : for (; start != last; start += delta)
4024 : {
4025 2060 : for (i = 0; i < lensub; i++)
4026 : {
4027 1852 : if (x->value.character.string[start + i]
4028 1852 : != y->value.character.string[i])
4029 : break;
4030 : }
4031 1180 : if (i == lensub)
4032 : {
4033 208 : index = start + 1;
4034 208 : goto done;
4035 : }
4036 : }
4037 :
4038 30 : done:
4039 262 : mpz_set_si (result->value.integer, index);
4040 262 : return range_check (result, "INDEX");
4041 : }
4042 :
4043 : static gfc_expr *
4044 7462 : simplify_intconv (gfc_expr *e, int kind, const char *name)
4045 : {
4046 7462 : gfc_expr *result = NULL;
4047 7462 : int tmp1, tmp2;
4048 :
4049 : /* Convert BOZ to integer, and return without range checking. */
4050 7462 : if (e->ts.type == BT_BOZ)
4051 : {
4052 1628 : if (!gfc_boz2int (e, kind))
4053 : return NULL;
4054 1628 : result = gfc_copy_expr (e);
4055 1628 : return result;
4056 : }
4057 :
4058 5834 : if (e->expr_type != EXPR_CONSTANT)
4059 : return NULL;
4060 :
4061 : /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
4062 : warnings. */
4063 1362 : tmp1 = warn_conversion;
4064 1362 : tmp2 = warn_conversion_extra;
4065 1362 : warn_conversion = warn_conversion_extra = 0;
4066 :
4067 1362 : result = gfc_convert_constant (e, BT_INTEGER, kind);
4068 :
4069 1362 : warn_conversion = tmp1;
4070 1362 : warn_conversion_extra = tmp2;
4071 :
4072 1362 : if (result == &gfc_bad_expr)
4073 : return &gfc_bad_expr;
4074 :
4075 1362 : return range_check (result, name);
4076 : }
4077 :
4078 :
4079 : gfc_expr *
4080 7359 : gfc_simplify_int (gfc_expr *e, gfc_expr *k)
4081 : {
4082 7359 : int kind;
4083 :
4084 7359 : kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
4085 7359 : if (kind == -1)
4086 : return &gfc_bad_expr;
4087 :
4088 7359 : return simplify_intconv (e, kind, "INT");
4089 : }
4090 :
4091 : gfc_expr *
4092 58 : gfc_simplify_int2 (gfc_expr *e)
4093 : {
4094 58 : return simplify_intconv (e, 2, "INT2");
4095 : }
4096 :
4097 :
4098 : gfc_expr *
4099 45 : gfc_simplify_int8 (gfc_expr *e)
4100 : {
4101 45 : return simplify_intconv (e, 8, "INT8");
4102 : }
4103 :
4104 :
4105 : gfc_expr *
4106 0 : gfc_simplify_long (gfc_expr *e)
4107 : {
4108 0 : return simplify_intconv (e, 4, "LONG");
4109 : }
4110 :
4111 :
4112 : gfc_expr *
4113 1837 : gfc_simplify_ifix (gfc_expr *e)
4114 : {
4115 1837 : gfc_expr *rtrunc, *result;
4116 :
4117 1837 : if (e->expr_type != EXPR_CONSTANT)
4118 : return NULL;
4119 :
4120 127 : rtrunc = gfc_copy_expr (e);
4121 127 : mpfr_trunc (rtrunc->value.real, e->value.real);
4122 :
4123 127 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4124 : &e->where);
4125 127 : gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
4126 :
4127 127 : gfc_free_expr (rtrunc);
4128 :
4129 127 : return range_check (result, "IFIX");
4130 : }
4131 :
4132 :
4133 : gfc_expr *
4134 783 : gfc_simplify_idint (gfc_expr *e)
4135 : {
4136 783 : gfc_expr *rtrunc, *result;
4137 :
4138 783 : if (e->expr_type != EXPR_CONSTANT)
4139 : return NULL;
4140 :
4141 50 : rtrunc = gfc_copy_expr (e);
4142 50 : mpfr_trunc (rtrunc->value.real, e->value.real);
4143 :
4144 50 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4145 : &e->where);
4146 50 : gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
4147 :
4148 50 : gfc_free_expr (rtrunc);
4149 :
4150 50 : return range_check (result, "IDINT");
4151 : }
4152 :
4153 : gfc_expr *
4154 459 : gfc_simplify_uint (gfc_expr *e, gfc_expr *k)
4155 : {
4156 459 : gfc_expr *result = NULL;
4157 459 : int kind;
4158 :
4159 : /* KIND is always an integer. */
4160 :
4161 459 : kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
4162 459 : if (kind == -1)
4163 : return &gfc_bad_expr;
4164 :
4165 : /* Convert BOZ to integer, and return without range checking. */
4166 459 : if (e->ts.type == BT_BOZ)
4167 : {
4168 6 : if (!gfc_boz2uint (e, kind))
4169 : return NULL;
4170 6 : result = gfc_copy_expr (e);
4171 6 : return result;
4172 : }
4173 :
4174 453 : if (e->expr_type != EXPR_CONSTANT)
4175 : return NULL;
4176 :
4177 165 : result = gfc_convert_constant (e, BT_UNSIGNED, kind);
4178 :
4179 165 : if (result == &gfc_bad_expr)
4180 : return &gfc_bad_expr;
4181 :
4182 165 : return range_check (result, "UINT");
4183 : }
4184 :
4185 :
4186 : gfc_expr *
4187 4382 : gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
4188 : {
4189 4382 : gfc_expr *result;
4190 4382 : bt type;
4191 :
4192 4382 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4193 : return NULL;
4194 :
4195 3055 : type = x->ts.type == BT_UNSIGNED ? BT_UNSIGNED : BT_INTEGER;
4196 3055 : result = gfc_get_constant_expr (type, x->ts.kind, &x->where);
4197 3055 : mpz_ior (result->value.integer, x->value.integer, y->value.integer);
4198 :
4199 3055 : return range_check (result, "IOR");
4200 : }
4201 :
4202 :
4203 : static gfc_expr *
4204 96 : do_bit_xor (gfc_expr *result, gfc_expr *e)
4205 : {
4206 96 : if (flag_unsigned)
4207 : {
4208 72 : gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
4209 : && e->expr_type == EXPR_CONSTANT);
4210 72 : gcc_assert ((result->ts.type == BT_INTEGER
4211 : || result->ts.type == BT_UNSIGNED)
4212 : && result->expr_type == EXPR_CONSTANT);
4213 : }
4214 : else
4215 : {
4216 24 : gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
4217 24 : gcc_assert (result->ts.type == BT_INTEGER
4218 : && result->expr_type == EXPR_CONSTANT);
4219 : }
4220 :
4221 96 : mpz_xor (result->value.integer, result->value.integer, e->value.integer);
4222 96 : return result;
4223 : }
4224 :
4225 :
4226 : gfc_expr *
4227 259 : gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
4228 : {
4229 259 : return simplify_transformation (array, dim, mask, 0, do_bit_xor);
4230 : }
4231 :
4232 :
4233 : gfc_expr *
4234 46 : gfc_simplify_is_iostat_end (gfc_expr *x)
4235 : {
4236 46 : if (x->expr_type != EXPR_CONSTANT)
4237 : return NULL;
4238 :
4239 28 : return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
4240 28 : mpz_cmp_si (x->value.integer,
4241 28 : LIBERROR_END) == 0);
4242 : }
4243 :
4244 :
4245 : gfc_expr *
4246 70 : gfc_simplify_is_iostat_eor (gfc_expr *x)
4247 : {
4248 70 : if (x->expr_type != EXPR_CONSTANT)
4249 : return NULL;
4250 :
4251 16 : return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
4252 16 : mpz_cmp_si (x->value.integer,
4253 16 : LIBERROR_EOR) == 0);
4254 : }
4255 :
4256 :
4257 : gfc_expr *
4258 1568 : gfc_simplify_isnan (gfc_expr *x)
4259 : {
4260 1568 : if (x->expr_type != EXPR_CONSTANT)
4261 : return NULL;
4262 :
4263 194 : return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
4264 194 : mpfr_nan_p (x->value.real));
4265 : }
4266 :
4267 :
4268 : /* Performs a shift on its first argument. Depending on the last
4269 : argument, the shift can be arithmetic, i.e. with filling from the
4270 : left like in the SHIFTA intrinsic. */
4271 : static gfc_expr *
4272 9828 : simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
4273 : bool arithmetic, int direction)
4274 : {
4275 9828 : gfc_expr *result;
4276 9828 : int ashift, *bits, i, k, bitsize, shift;
4277 :
4278 9828 : if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
4279 : return NULL;
4280 :
4281 7729 : gfc_extract_int (s, &shift);
4282 :
4283 7729 : k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4284 7729 : if (e->ts.type == BT_INTEGER)
4285 7627 : bitsize = gfc_integer_kinds[k].bit_size;
4286 : else
4287 102 : bitsize = gfc_unsigned_kinds[k].bit_size;
4288 :
4289 7729 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4290 :
4291 7729 : if (shift == 0)
4292 : {
4293 1194 : mpz_set (result->value.integer, e->value.integer);
4294 1194 : return result;
4295 : }
4296 :
4297 6535 : if (direction > 0 && shift < 0)
4298 : {
4299 : /* Left shift, as in SHIFTL. */
4300 0 : gfc_error ("Second argument of %s is negative at %L", name, &e->where);
4301 0 : return &gfc_bad_expr;
4302 : }
4303 6535 : else if (direction < 0)
4304 : {
4305 : /* Right shift, as in SHIFTR or SHIFTA. */
4306 2832 : if (shift < 0)
4307 : {
4308 0 : gfc_error ("Second argument of %s is negative at %L",
4309 : name, &e->where);
4310 0 : return &gfc_bad_expr;
4311 : }
4312 :
4313 2832 : shift = -shift;
4314 : }
4315 :
4316 6535 : ashift = (shift >= 0 ? shift : -shift);
4317 :
4318 6535 : if (ashift > bitsize)
4319 : {
4320 0 : gfc_error ("Magnitude of second argument of %s exceeds bit size "
4321 : "at %L", name, &e->where);
4322 0 : return &gfc_bad_expr;
4323 : }
4324 :
4325 6535 : bits = XCNEWVEC (int, bitsize);
4326 :
4327 325358 : for (i = 0; i < bitsize; i++)
4328 312288 : bits[i] = mpz_tstbit (e->value.integer, i);
4329 :
4330 6535 : if (shift > 0)
4331 : {
4332 : /* Left shift. */
4333 86026 : for (i = 0; i < shift; i++)
4334 82467 : mpz_clrbit (result->value.integer, i);
4335 :
4336 85300 : for (i = 0; i < bitsize - shift; i++)
4337 : {
4338 81741 : if (bits[i] == 0)
4339 53126 : mpz_clrbit (result->value.integer, i + shift);
4340 : else
4341 28615 : mpz_setbit (result->value.integer, i + shift);
4342 : }
4343 : }
4344 : else
4345 : {
4346 : /* Right shift. */
4347 2976 : if (arithmetic && bits[bitsize - 1])
4348 504 : for (i = bitsize - 1; i >= bitsize - ashift; i--)
4349 438 : mpz_setbit (result->value.integer, i);
4350 : else
4351 75186 : for (i = bitsize - 1; i >= bitsize - ashift; i--)
4352 72276 : mpz_clrbit (result->value.integer, i);
4353 :
4354 78342 : for (i = bitsize - 1; i >= ashift; i--)
4355 : {
4356 75366 : if (bits[i] == 0)
4357 46920 : mpz_clrbit (result->value.integer, i - ashift);
4358 : else
4359 28446 : mpz_setbit (result->value.integer, i - ashift);
4360 : }
4361 : }
4362 :
4363 6535 : if (result->ts.type == BT_INTEGER)
4364 6433 : gfc_convert_mpz_to_signed (result->value.integer, bitsize);
4365 : else
4366 102 : gfc_reduce_unsigned(result);
4367 :
4368 6535 : free (bits);
4369 :
4370 6535 : return result;
4371 : }
4372 :
4373 :
4374 : gfc_expr *
4375 2103 : gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
4376 : {
4377 2103 : return simplify_shift (e, s, "ISHFT", false, 0);
4378 : }
4379 :
4380 :
4381 : gfc_expr *
4382 192 : gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
4383 : {
4384 192 : return simplify_shift (e, s, "LSHIFT", false, 1);
4385 : }
4386 :
4387 :
4388 : gfc_expr *
4389 66 : gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
4390 : {
4391 66 : return simplify_shift (e, s, "RSHIFT", true, -1);
4392 : }
4393 :
4394 :
4395 : gfc_expr *
4396 438 : gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
4397 : {
4398 438 : return simplify_shift (e, s, "SHIFTA", true, -1);
4399 : }
4400 :
4401 :
4402 : gfc_expr *
4403 3753 : gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
4404 : {
4405 3753 : return simplify_shift (e, s, "SHIFTL", false, 1);
4406 : }
4407 :
4408 :
4409 : gfc_expr *
4410 3276 : gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
4411 : {
4412 3276 : return simplify_shift (e, s, "SHIFTR", false, -1);
4413 : }
4414 :
4415 :
4416 : gfc_expr *
4417 1929 : gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
4418 : {
4419 1929 : gfc_expr *result;
4420 1929 : int shift, ashift, isize, ssize, delta, k;
4421 1929 : int i, *bits;
4422 :
4423 1929 : if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
4424 : return NULL;
4425 :
4426 411 : gfc_extract_int (s, &shift);
4427 :
4428 411 : k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4429 411 : isize = gfc_integer_kinds[k].bit_size;
4430 :
4431 411 : if (sz != NULL)
4432 : {
4433 213 : if (sz->expr_type != EXPR_CONSTANT)
4434 : return NULL;
4435 :
4436 213 : gfc_extract_int (sz, &ssize);
4437 :
4438 213 : if (ssize > isize || ssize <= 0)
4439 : return &gfc_bad_expr;
4440 : }
4441 : else
4442 198 : ssize = isize;
4443 :
4444 411 : if (shift >= 0)
4445 : ashift = shift;
4446 : else
4447 : ashift = -shift;
4448 :
4449 411 : if (ashift > ssize)
4450 : {
4451 11 : if (sz == NULL)
4452 4 : gfc_error ("Magnitude of second argument of ISHFTC exceeds "
4453 : "BIT_SIZE of first argument at %C");
4454 : else
4455 7 : gfc_error ("Absolute value of SHIFT shall be less than or equal "
4456 : "to SIZE at %C");
4457 11 : return &gfc_bad_expr;
4458 : }
4459 :
4460 400 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4461 :
4462 400 : mpz_set (result->value.integer, e->value.integer);
4463 :
4464 400 : if (shift == 0)
4465 : return result;
4466 :
4467 364 : if (result->ts.type == BT_INTEGER)
4468 352 : gfc_convert_mpz_to_unsigned (result->value.integer, isize);
4469 :
4470 364 : bits = XCNEWVEC (int, ssize);
4471 :
4472 6877 : for (i = 0; i < ssize; i++)
4473 6149 : bits[i] = mpz_tstbit (e->value.integer, i);
4474 :
4475 364 : delta = ssize - ashift;
4476 :
4477 364 : if (shift > 0)
4478 : {
4479 3975 : for (i = 0; i < delta; i++)
4480 : {
4481 3707 : if (bits[i] == 0)
4482 2226 : mpz_clrbit (result->value.integer, i + shift);
4483 : else
4484 1481 : mpz_setbit (result->value.integer, i + shift);
4485 : }
4486 :
4487 1030 : for (i = delta; i < ssize; i++)
4488 : {
4489 762 : if (bits[i] == 0)
4490 612 : mpz_clrbit (result->value.integer, i - delta);
4491 : else
4492 150 : mpz_setbit (result->value.integer, i - delta);
4493 : }
4494 : }
4495 : else
4496 : {
4497 288 : for (i = 0; i < ashift; i++)
4498 : {
4499 192 : if (bits[i] == 0)
4500 90 : mpz_clrbit (result->value.integer, i + delta);
4501 : else
4502 102 : mpz_setbit (result->value.integer, i + delta);
4503 : }
4504 :
4505 1584 : for (i = ashift; i < ssize; i++)
4506 : {
4507 1488 : if (bits[i] == 0)
4508 624 : mpz_clrbit (result->value.integer, i + shift);
4509 : else
4510 864 : mpz_setbit (result->value.integer, i + shift);
4511 : }
4512 : }
4513 :
4514 364 : if (result->ts.type == BT_INTEGER)
4515 352 : gfc_convert_mpz_to_signed (result->value.integer, isize);
4516 :
4517 364 : free (bits);
4518 364 : return result;
4519 : }
4520 :
4521 :
4522 : gfc_expr *
4523 5063 : gfc_simplify_kind (gfc_expr *e)
4524 : {
4525 5063 : return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
4526 : }
4527 :
4528 :
4529 : static gfc_expr *
4530 13268 : simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
4531 : gfc_array_spec *as, gfc_ref *ref, bool coarray)
4532 : {
4533 13268 : gfc_expr *l, *u, *result;
4534 13268 : int k;
4535 :
4536 22213 : k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4537 : gfc_default_integer_kind);
4538 13268 : if (k == -1)
4539 : return &gfc_bad_expr;
4540 :
4541 13268 : result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
4542 :
4543 : /* For non-variables, LBOUND(expr, DIM=n) = 1 and
4544 : UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
4545 13268 : if (!coarray && array->expr_type != EXPR_VARIABLE)
4546 : {
4547 1414 : if (upper)
4548 : {
4549 782 : gfc_expr* dim = result;
4550 782 : mpz_set_si (dim->value.integer, d);
4551 :
4552 782 : result = simplify_size (array, dim, k);
4553 782 : gfc_free_expr (dim);
4554 782 : if (!result)
4555 375 : goto returnNull;
4556 : }
4557 : else
4558 632 : mpz_set_si (result->value.integer, 1);
4559 :
4560 1039 : goto done;
4561 : }
4562 :
4563 : /* Otherwise, we have a variable expression. */
4564 11854 : gcc_assert (array->expr_type == EXPR_VARIABLE);
4565 11854 : gcc_assert (as);
4566 :
4567 11854 : if (!gfc_resolve_array_spec (as, 0))
4568 : return NULL;
4569 :
4570 : /* The last dimension of an assumed-size array is special. */
4571 11851 : if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
4572 1584 : || (coarray && d == as->rank + as->corank
4573 565 : && (!upper || flag_coarray == GFC_FCOARRAY_SINGLE)))
4574 : {
4575 659 : if (as->lower[d-1] && as->lower[d-1]->expr_type == EXPR_CONSTANT)
4576 : {
4577 432 : gfc_free_expr (result);
4578 432 : return gfc_copy_expr (as->lower[d-1]);
4579 : }
4580 :
4581 227 : goto returnNull;
4582 : }
4583 :
4584 : /* Then, we need to know the extent of the given dimension. */
4585 10071 : if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
4586 : {
4587 10689 : gfc_expr *declared_bound;
4588 10689 : int empty_bound;
4589 10689 : bool constant_lbound, constant_ubound;
4590 :
4591 10689 : l = as->lower[d-1];
4592 10689 : u = as->upper[d-1];
4593 :
4594 10689 : gcc_assert (l != NULL);
4595 :
4596 10689 : constant_lbound = l->expr_type == EXPR_CONSTANT;
4597 10689 : constant_ubound = u && u->expr_type == EXPR_CONSTANT;
4598 :
4599 10689 : empty_bound = upper ? 0 : 1;
4600 10689 : declared_bound = upper ? u : l;
4601 :
4602 10689 : if ((!upper && !constant_lbound)
4603 9801 : || (upper && !constant_ubound))
4604 2250 : goto returnNull;
4605 :
4606 8439 : if (!coarray)
4607 : {
4608 : /* For {L,U}BOUND, the value depends on whether the array
4609 : is empty. We can nevertheless simplify if the declared bound
4610 : has the same value as that of an empty array, in which case
4611 : the result isn't dependent on the array emptiness. */
4612 7630 : if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0)
4613 3514 : mpz_set_si (result->value.integer, empty_bound);
4614 4116 : else if (!constant_lbound || !constant_ubound)
4615 : /* Array emptiness can't be determined, we can't simplify. */
4616 1815 : goto returnNull;
4617 2301 : else if (mpz_cmp (l->value.integer, u->value.integer) > 0)
4618 97 : mpz_set_si (result->value.integer, empty_bound);
4619 : else
4620 2204 : mpz_set (result->value.integer, declared_bound->value.integer);
4621 : }
4622 : else
4623 809 : mpz_set (result->value.integer, declared_bound->value.integer);
4624 : }
4625 : else
4626 : {
4627 503 : if (upper)
4628 : {
4629 : int d2 = 0, cnt = 0;
4630 523 : for (int idx = 0; idx < ref->u.ar.dimen; ++idx)
4631 : {
4632 523 : if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT)
4633 120 : d2++;
4634 403 : else if (cnt < d - 1)
4635 102 : cnt++;
4636 : else
4637 : break;
4638 : }
4639 301 : if (!gfc_ref_dimen_size (&ref->u.ar, d2 + d - 1, &result->value.integer, NULL))
4640 73 : goto returnNull;
4641 : }
4642 : else
4643 202 : mpz_set_si (result->value.integer, (long int) 1);
4644 : }
4645 :
4646 8093 : done:
4647 8093 : return range_check (result, upper ? "UBOUND" : "LBOUND");
4648 :
4649 4740 : returnNull:
4650 4740 : gfc_free_expr (result);
4651 4740 : return NULL;
4652 : }
4653 :
4654 :
4655 : static gfc_expr *
4656 34546 : simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4657 : {
4658 34546 : gfc_ref *ref;
4659 34546 : gfc_array_spec *as;
4660 34546 : ar_type type = AR_UNKNOWN;
4661 34546 : int d;
4662 :
4663 34546 : if (array->ts.type == BT_CLASS)
4664 : return NULL;
4665 :
4666 33172 : if (array->expr_type != EXPR_VARIABLE)
4667 : {
4668 1242 : as = NULL;
4669 1242 : ref = NULL;
4670 1242 : goto done;
4671 : }
4672 :
4673 : /* Do not attempt to resolve if error has already been issued. */
4674 31930 : if (array->symtree->n.sym->error)
4675 : return NULL;
4676 :
4677 : /* Follow any component references. */
4678 31929 : as = array->symtree->n.sym->as;
4679 33016 : for (ref = array->ref; ref; ref = ref->next)
4680 : {
4681 33016 : switch (ref->type)
4682 : {
4683 32063 : case REF_ARRAY:
4684 32063 : type = ref->u.ar.type;
4685 32063 : switch (ref->u.ar.type)
4686 : {
4687 134 : case AR_ELEMENT:
4688 134 : as = NULL;
4689 134 : continue;
4690 :
4691 31066 : case AR_FULL:
4692 : /* We're done because 'as' has already been set in the
4693 : previous iteration. */
4694 31066 : goto done;
4695 :
4696 : case AR_UNKNOWN:
4697 : return NULL;
4698 :
4699 863 : case AR_SECTION:
4700 863 : as = ref->u.ar.as;
4701 863 : goto done;
4702 : }
4703 :
4704 0 : gcc_unreachable ();
4705 :
4706 953 : case REF_COMPONENT:
4707 953 : as = ref->u.c.component->as;
4708 953 : continue;
4709 :
4710 0 : case REF_SUBSTRING:
4711 0 : case REF_INQUIRY:
4712 0 : continue;
4713 : }
4714 : }
4715 :
4716 0 : gcc_unreachable ();
4717 :
4718 33171 : done:
4719 :
4720 33171 : if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
4721 11257 : || (as->type == AS_ASSUMED_SHAPE && upper)))
4722 : return NULL;
4723 :
4724 : /* 'array' shall not be an unallocated allocatable variable or a pointer that
4725 : is not associated. */
4726 10365 : if (array->expr_type == EXPR_VARIABLE
4727 10365 : && (gfc_expr_attr (array).allocatable || gfc_expr_attr (array).pointer))
4728 6 : return NULL;
4729 :
4730 10359 : gcc_assert (!as
4731 : || (as->type != AS_DEFERRED
4732 : && array->expr_type == EXPR_VARIABLE
4733 : && !gfc_expr_attr (array).allocatable
4734 : && !gfc_expr_attr (array).pointer));
4735 :
4736 10359 : if (dim == NULL)
4737 : {
4738 : /* Multi-dimensional bounds. */
4739 1579 : gfc_expr *bounds[GFC_MAX_DIMENSIONS];
4740 1579 : gfc_expr *e;
4741 1579 : int k;
4742 :
4743 : /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4744 1579 : if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE)
4745 : {
4746 : /* An error message will be emitted in
4747 : check_assumed_size_reference (resolve.cc). */
4748 : return &gfc_bad_expr;
4749 : }
4750 :
4751 : /* Simplify the bounds for each dimension. */
4752 4146 : for (d = 0; d < array->rank; d++)
4753 : {
4754 2902 : bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
4755 : false);
4756 2902 : if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
4757 : {
4758 : int j;
4759 :
4760 340 : for (j = 0; j < d; j++)
4761 6 : gfc_free_expr (bounds[j]);
4762 :
4763 334 : if (gfc_seen_div0)
4764 : return &gfc_bad_expr;
4765 : else
4766 : return bounds[d];
4767 : }
4768 : }
4769 :
4770 : /* Allocate the result expression. */
4771 1942 : k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4772 : gfc_default_integer_kind);
4773 1244 : if (k == -1)
4774 : return &gfc_bad_expr;
4775 :
4776 1244 : e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
4777 :
4778 : /* The result is a rank 1 array; its size is the rank of the first
4779 : argument to {L,U}BOUND. */
4780 1244 : e->rank = 1;
4781 1244 : e->shape = gfc_get_shape (1);
4782 1244 : mpz_init_set_ui (e->shape[0], array->rank);
4783 :
4784 : /* Create the constructor for this array. */
4785 5050 : for (d = 0; d < array->rank; d++)
4786 2562 : gfc_constructor_append_expr (&e->value.constructor,
4787 : bounds[d], &e->where);
4788 :
4789 : return e;
4790 : }
4791 : else
4792 : {
4793 : /* A DIM argument is specified. */
4794 8780 : if (dim->expr_type != EXPR_CONSTANT)
4795 : return NULL;
4796 :
4797 8780 : d = mpz_get_si (dim->value.integer);
4798 :
4799 8780 : if ((d < 1 || d > array->rank)
4800 8780 : || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
4801 : {
4802 0 : gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4803 0 : return &gfc_bad_expr;
4804 : }
4805 :
4806 8363 : if (as && as->type == AS_ASSUMED_RANK)
4807 : return NULL;
4808 :
4809 8780 : return simplify_bound_dim (array, kind, d, upper, as, ref, false);
4810 : }
4811 : }
4812 :
4813 :
4814 : static gfc_expr *
4815 1717 : simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4816 : {
4817 1717 : gfc_ref *ref;
4818 1717 : gfc_array_spec *as;
4819 1717 : int d;
4820 :
4821 1717 : if (array->expr_type != EXPR_VARIABLE)
4822 : return NULL;
4823 :
4824 : /* Follow any component references. */
4825 229 : as = (array->ts.type == BT_CLASS && CLASS_DATA (array))
4826 1717 : ? CLASS_DATA (array)->as
4827 1489 : : array->symtree->n.sym->as;
4828 2035 : for (ref = array->ref; ref; ref = ref->next)
4829 : {
4830 2034 : switch (ref->type)
4831 : {
4832 1716 : case REF_ARRAY:
4833 1716 : switch (ref->u.ar.type)
4834 : {
4835 457 : case AR_ELEMENT:
4836 457 : if (ref->u.ar.as->corank > 0)
4837 : {
4838 457 : gcc_assert (as == ref->u.ar.as);
4839 457 : goto done;
4840 : }
4841 0 : as = NULL;
4842 0 : continue;
4843 :
4844 1259 : case AR_FULL:
4845 : /* We're done because 'as' has already been set in the
4846 : previous iteration. */
4847 1259 : goto done;
4848 :
4849 : case AR_UNKNOWN:
4850 : return NULL;
4851 :
4852 0 : case AR_SECTION:
4853 0 : as = ref->u.ar.as;
4854 0 : goto done;
4855 : }
4856 :
4857 0 : gcc_unreachable ();
4858 :
4859 318 : case REF_COMPONENT:
4860 318 : as = ref->u.c.component->as;
4861 318 : continue;
4862 :
4863 0 : case REF_SUBSTRING:
4864 0 : case REF_INQUIRY:
4865 0 : continue;
4866 : }
4867 : }
4868 :
4869 1 : if (!as)
4870 0 : gcc_unreachable ();
4871 :
4872 1 : done:
4873 :
4874 1717 : if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
4875 : return NULL;
4876 :
4877 891 : if (dim == NULL)
4878 : {
4879 : /* Multi-dimensional cobounds. */
4880 : gfc_expr *bounds[GFC_MAX_DIMENSIONS];
4881 : gfc_expr *e;
4882 : int k;
4883 :
4884 : /* Simplify the cobounds for each dimension. */
4885 996 : for (d = 0; d < as->corank; d++)
4886 : {
4887 870 : bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
4888 : upper, as, ref, true);
4889 870 : if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
4890 : {
4891 : int j;
4892 :
4893 428 : for (j = 0; j < d; j++)
4894 240 : gfc_free_expr (bounds[j]);
4895 : return bounds[d];
4896 : }
4897 : }
4898 :
4899 : /* Allocate the result expression. */
4900 126 : e = gfc_get_expr ();
4901 126 : e->where = array->where;
4902 126 : e->expr_type = EXPR_ARRAY;
4903 126 : e->ts.type = BT_INTEGER;
4904 229 : k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
4905 : gfc_default_integer_kind);
4906 126 : if (k == -1)
4907 : {
4908 0 : gfc_free_expr (e);
4909 0 : return &gfc_bad_expr;
4910 : }
4911 126 : e->ts.kind = k;
4912 :
4913 : /* The result is a rank 1 array; its size is the rank of the first
4914 : argument to {L,U}COBOUND. */
4915 126 : e->rank = 1;
4916 126 : e->shape = gfc_get_shape (1);
4917 126 : mpz_init_set_ui (e->shape[0], as->corank);
4918 :
4919 : /* Create the constructor for this array. */
4920 694 : for (d = 0; d < as->corank; d++)
4921 442 : gfc_constructor_append_expr (&e->value.constructor,
4922 : bounds[d], &e->where);
4923 : return e;
4924 : }
4925 : else
4926 : {
4927 : /* A DIM argument is specified. */
4928 577 : if (dim->expr_type != EXPR_CONSTANT)
4929 : return NULL;
4930 :
4931 437 : d = mpz_get_si (dim->value.integer);
4932 :
4933 437 : if (d < 1 || d > as->corank)
4934 : {
4935 0 : gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4936 0 : return &gfc_bad_expr;
4937 : }
4938 :
4939 437 : return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
4940 : }
4941 : }
4942 :
4943 :
4944 : gfc_expr *
4945 19557 : gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4946 : {
4947 19557 : return simplify_bound (array, dim, kind, 0);
4948 : }
4949 :
4950 :
4951 : gfc_expr *
4952 619 : gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4953 : {
4954 619 : return simplify_cobound (array, dim, kind, 0);
4955 : }
4956 :
4957 : gfc_expr *
4958 1068 : gfc_simplify_leadz (gfc_expr *e)
4959 : {
4960 1068 : unsigned long lz, bs;
4961 1068 : int i;
4962 :
4963 1068 : if (e->expr_type != EXPR_CONSTANT)
4964 : return NULL;
4965 :
4966 258 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4967 258 : bs = gfc_integer_kinds[i].bit_size;
4968 258 : if (mpz_cmp_si (e->value.integer, 0) == 0)
4969 : lz = bs;
4970 222 : else if (mpz_cmp_si (e->value.integer, 0) < 0)
4971 : lz = 0;
4972 : else
4973 132 : lz = bs - mpz_sizeinbase (e->value.integer, 2);
4974 :
4975 258 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
4976 : }
4977 :
4978 :
4979 : /* Check for constant length of a substring. */
4980 :
4981 : static bool
4982 17031 : substring_has_constant_len (gfc_expr *e)
4983 : {
4984 17031 : gfc_ref *ref;
4985 17031 : HOST_WIDE_INT istart, iend, length;
4986 17031 : bool equal_length = false;
4987 :
4988 17031 : if (e->ts.type != BT_CHARACTER)
4989 : return false;
4990 :
4991 24289 : for (ref = e->ref; ref; ref = ref->next)
4992 7781 : if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY)
4993 : break;
4994 :
4995 17031 : if (!ref
4996 523 : || ref->type != REF_SUBSTRING
4997 523 : || !ref->u.ss.start
4998 523 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
4999 208 : || !ref->u.ss.end
5000 208 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
5001 : return false;
5002 :
5003 : /* Basic checks on substring starting and ending indices. */
5004 207 : if (!gfc_resolve_substring (ref, &equal_length))
5005 : return false;
5006 :
5007 207 : istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer);
5008 207 : iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer);
5009 :
5010 207 : if (istart <= iend)
5011 199 : length = iend - istart + 1;
5012 : else
5013 : length = 0;
5014 :
5015 : /* Fix substring length. */
5016 207 : e->value.character.length = length;
5017 :
5018 207 : return true;
5019 : }
5020 :
5021 :
5022 : gfc_expr *
5023 17538 : gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
5024 : {
5025 17538 : gfc_expr *result;
5026 17538 : int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
5027 :
5028 17538 : if (k == -1)
5029 : return &gfc_bad_expr;
5030 :
5031 17538 : if (e->expr_type == EXPR_CONSTANT
5032 17538 : || substring_has_constant_len (e))
5033 : {
5034 714 : result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
5035 714 : mpz_set_si (result->value.integer, e->value.character.length);
5036 714 : return range_check (result, "LEN");
5037 : }
5038 16824 : else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
5039 5553 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
5040 2883 : && e->ts.u.cl->length->ts.type == BT_INTEGER)
5041 : {
5042 2883 : result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
5043 2883 : mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
5044 2883 : return range_check (result, "LEN");
5045 : }
5046 13941 : else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
5047 12055 : && e->symtree->n.sym)
5048 : {
5049 12055 : if (e->symtree->n.sym->ts.type != BT_DERIVED
5050 11631 : && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
5051 965 : && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
5052 367 : && e->symtree->n.sym->assoc->target->symtree->n.sym
5053 367 : && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
5054 : /* The expression in assoc->target points to a ref to the _data
5055 : component of the unlimited polymorphic entity. To get the _len
5056 : component the last _data ref needs to be stripped and a ref to the
5057 : _len component added. */
5058 367 : return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
5059 11688 : else if (e->symtree->n.sym->ts.type == BT_DERIVED
5060 424 : && e->ref && e->ref->type == REF_COMPONENT
5061 424 : && e->ref->u.c.component->attr.pdt_string
5062 48 : && e->ref->u.c.component->ts.type == BT_CHARACTER
5063 48 : && e->ref->u.c.component->ts.u.cl->length)
5064 : {
5065 48 : if (gfc_init_expr_flag)
5066 : {
5067 6 : gfc_expr* tmp;
5068 12 : tmp = gfc_pdt_find_component_copy_initializer (e->symtree->n.sym,
5069 : e->ref->u.c
5070 : .component->ts.u.cl
5071 6 : ->length->symtree
5072 : ->name);
5073 6 : if (tmp)
5074 : return tmp;
5075 : }
5076 : else
5077 : {
5078 42 : gfc_expr *len_expr = gfc_copy_expr (e);
5079 42 : gfc_free_ref_list (len_expr->ref);
5080 42 : len_expr->ref = NULL;
5081 42 : gfc_find_component (len_expr->symtree->n.sym->ts.u.derived, e->ref
5082 42 : ->u.c.component->ts.u.cl->length->symtree
5083 : ->name,
5084 : false, true, &len_expr->ref);
5085 42 : len_expr->ts = len_expr->ref->u.c.component->ts;
5086 42 : return len_expr;
5087 : }
5088 : }
5089 : }
5090 1886 : else if (e->expr_type == EXPR_ARRAY && e->ts.type == BT_CHARACTER
5091 127 : && e->ts.u.cl
5092 127 : && e->ts.u.cl->length_from_typespec
5093 126 : && e->ts.u.cl->length
5094 126 : && e->ts.u.cl->length->ts.type == BT_INTEGER)
5095 : {
5096 126 : gfc_typespec ts;
5097 126 : gfc_clear_ts (&ts);
5098 126 : ts.type = BT_INTEGER;
5099 126 : ts.kind = k;
5100 126 : result = gfc_copy_expr (e->ts.u.cl->length);
5101 126 : gfc_convert_type_warn (result, &ts, 2, 0);
5102 126 : return result;
5103 : }
5104 :
5105 : return NULL;
5106 : }
5107 :
5108 :
5109 : gfc_expr *
5110 4181 : gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
5111 : {
5112 4181 : gfc_expr *result;
5113 4181 : size_t count, len, i;
5114 4181 : int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
5115 :
5116 4181 : if (k == -1)
5117 : return &gfc_bad_expr;
5118 :
5119 : /* If the expression is either an array element or section, an array
5120 : parameter must be built so that the reference can be applied. Constant
5121 : references should have already been simplified away. All other cases
5122 : can proceed to translation, where kind conversion will occur silently. */
5123 4181 : if (e->expr_type == EXPR_VARIABLE
5124 3334 : && e->ts.type == BT_CHARACTER
5125 3334 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER
5126 129 : && e->ref && e->ref->type == REF_ARRAY
5127 129 : && e->ref->u.ar.type != AR_FULL
5128 82 : && e->symtree->n.sym->value)
5129 : {
5130 82 : char name[2*GFC_MAX_SYMBOL_LEN + 12];
5131 82 : gfc_namespace *ns = e->symtree->n.sym->ns;
5132 82 : gfc_symtree *st;
5133 82 : gfc_expr *expr;
5134 82 : gfc_expr *p;
5135 82 : gfc_constructor *c;
5136 82 : int cnt = 0;
5137 :
5138 82 : sprintf (name, "_len_trim_%s_%s", e->symtree->n.sym->name,
5139 82 : ns->proc_name->name);
5140 82 : st = gfc_find_symtree (ns->sym_root, name);
5141 82 : if (st)
5142 44 : goto already_built;
5143 :
5144 : /* Recursively call this fcn to simplify the constructor elements. */
5145 38 : expr = gfc_copy_expr (e->symtree->n.sym->value);
5146 38 : expr->ts.type = BT_INTEGER;
5147 38 : expr->ts.kind = k;
5148 38 : expr->ts.u.cl = NULL;
5149 38 : c = gfc_constructor_first (expr->value.constructor);
5150 237 : for (; c; c = gfc_constructor_next (c))
5151 : {
5152 161 : if (c->iterator)
5153 0 : continue;
5154 :
5155 161 : if (c->expr && c->expr->ts.type == BT_CHARACTER)
5156 : {
5157 161 : p = gfc_simplify_len_trim (c->expr, kind);
5158 161 : if (p == NULL)
5159 0 : goto clean_up;
5160 161 : gfc_replace_expr (c->expr, p);
5161 161 : cnt++;
5162 : }
5163 : }
5164 :
5165 38 : if (cnt)
5166 : {
5167 : /* Build a new parameter to take the result. */
5168 38 : st = gfc_new_symtree (&ns->sym_root, name);
5169 38 : st->n.sym = gfc_new_symbol (st->name, ns);
5170 38 : st->n.sym->value = expr;
5171 38 : st->n.sym->ts = expr->ts;
5172 38 : st->n.sym->attr.dimension = 1;
5173 38 : st->n.sym->attr.save = SAVE_IMPLICIT;
5174 38 : st->n.sym->attr.flavor = FL_PARAMETER;
5175 38 : st->n.sym->as = gfc_copy_array_spec (e->symtree->n.sym->as);
5176 38 : gfc_set_sym_referenced (st->n.sym);
5177 38 : st->n.sym->refs++;
5178 38 : gfc_commit_symbol (st->n.sym);
5179 :
5180 82 : already_built:
5181 : /* Build a return expression. */
5182 82 : expr = gfc_copy_expr (e);
5183 82 : expr->ts = st->n.sym->ts;
5184 82 : expr->symtree = st;
5185 82 : gfc_expression_rank (expr);
5186 82 : return expr;
5187 : }
5188 :
5189 0 : clean_up:
5190 0 : gfc_free_expr (expr);
5191 0 : return NULL;
5192 : }
5193 :
5194 4099 : if (e->expr_type != EXPR_CONSTANT)
5195 : return NULL;
5196 :
5197 388 : len = e->value.character.length;
5198 1215 : for (count = 0, i = 1; i <= len; i++)
5199 1203 : if (e->value.character.string[len - i] == ' ')
5200 827 : count++;
5201 : else
5202 : break;
5203 :
5204 388 : result = gfc_get_int_expr (k, &e->where, len - count);
5205 388 : return range_check (result, "LEN_TRIM");
5206 : }
5207 :
5208 : gfc_expr *
5209 50 : gfc_simplify_lgamma (gfc_expr *x)
5210 : {
5211 50 : gfc_expr *result;
5212 50 : int sg;
5213 :
5214 50 : if (x->expr_type != EXPR_CONSTANT)
5215 : return NULL;
5216 :
5217 42 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5218 42 : mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
5219 :
5220 42 : return range_check (result, "LGAMMA");
5221 : }
5222 :
5223 :
5224 : gfc_expr *
5225 55 : gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
5226 : {
5227 55 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
5228 : return NULL;
5229 :
5230 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
5231 2 : gfc_compare_string (a, b) >= 0);
5232 : }
5233 :
5234 :
5235 : gfc_expr *
5236 81 : gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
5237 : {
5238 81 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
5239 : return NULL;
5240 :
5241 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
5242 2 : gfc_compare_string (a, b) > 0);
5243 : }
5244 :
5245 :
5246 : gfc_expr *
5247 64 : gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
5248 : {
5249 64 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
5250 : return NULL;
5251 :
5252 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
5253 2 : gfc_compare_string (a, b) <= 0);
5254 : }
5255 :
5256 :
5257 : gfc_expr *
5258 72 : gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
5259 : {
5260 72 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
5261 : return NULL;
5262 :
5263 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
5264 2 : gfc_compare_string (a, b) < 0);
5265 : }
5266 :
5267 :
5268 : gfc_expr *
5269 494 : gfc_simplify_log (gfc_expr *x)
5270 : {
5271 494 : gfc_expr *result;
5272 :
5273 494 : if (x->expr_type != EXPR_CONSTANT)
5274 : return NULL;
5275 :
5276 229 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5277 :
5278 229 : switch (x->ts.type)
5279 : {
5280 106 : case BT_REAL:
5281 106 : if (mpfr_sgn (x->value.real) <= 0)
5282 : {
5283 0 : gfc_error ("Argument of LOG at %L cannot be less than or equal "
5284 : "to zero", &x->where);
5285 0 : gfc_free_expr (result);
5286 0 : return &gfc_bad_expr;
5287 : }
5288 :
5289 106 : mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
5290 106 : break;
5291 :
5292 123 : case BT_COMPLEX:
5293 123 : if (mpfr_zero_p (mpc_realref (x->value.complex))
5294 0 : && mpfr_zero_p (mpc_imagref (x->value.complex)))
5295 : {
5296 0 : gfc_error ("Complex argument of LOG at %L cannot be zero",
5297 : &x->where);
5298 0 : gfc_free_expr (result);
5299 0 : return &gfc_bad_expr;
5300 : }
5301 :
5302 123 : gfc_set_model_kind (x->ts.kind);
5303 123 : mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5304 123 : break;
5305 :
5306 0 : default:
5307 0 : gfc_internal_error ("gfc_simplify_log: bad type");
5308 : }
5309 :
5310 229 : return range_check (result, "LOG");
5311 : }
5312 :
5313 :
5314 : gfc_expr *
5315 328 : gfc_simplify_log10 (gfc_expr *x)
5316 : {
5317 328 : gfc_expr *result;
5318 :
5319 328 : if (x->expr_type != EXPR_CONSTANT)
5320 : return NULL;
5321 :
5322 82 : if (mpfr_sgn (x->value.real) <= 0)
5323 : {
5324 0 : gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
5325 : "to zero", &x->where);
5326 0 : return &gfc_bad_expr;
5327 : }
5328 :
5329 82 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5330 82 : mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
5331 :
5332 82 : return range_check (result, "LOG10");
5333 : }
5334 :
5335 :
5336 : gfc_expr *
5337 52 : gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
5338 : {
5339 52 : int kind;
5340 :
5341 52 : kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
5342 52 : if (kind < 0)
5343 : return &gfc_bad_expr;
5344 :
5345 52 : if (e->expr_type != EXPR_CONSTANT)
5346 : return NULL;
5347 :
5348 4 : return gfc_get_logical_expr (kind, &e->where, e->value.logical);
5349 : }
5350 :
5351 :
5352 : gfc_expr*
5353 1151 : gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
5354 : {
5355 1151 : gfc_expr *result;
5356 1151 : int row, result_rows, col, result_columns;
5357 1151 : int stride_a, offset_a, stride_b, offset_b;
5358 :
5359 1151 : if (!is_constant_array_expr (matrix_a)
5360 1151 : || !is_constant_array_expr (matrix_b))
5361 1088 : return NULL;
5362 :
5363 : /* MATMUL should do mixed-mode arithmetic. Set the result type. */
5364 63 : if (matrix_a->ts.type != matrix_b->ts.type)
5365 : {
5366 12 : gfc_expr e;
5367 12 : e.expr_type = EXPR_OP;
5368 12 : gfc_clear_ts (&e.ts);
5369 12 : e.value.op.op = INTRINSIC_NONE;
5370 12 : e.value.op.op1 = matrix_a;
5371 12 : e.value.op.op2 = matrix_b;
5372 12 : gfc_type_convert_binary (&e, 1);
5373 12 : result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where);
5374 : }
5375 : else
5376 : {
5377 51 : result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind,
5378 : &matrix_a->where);
5379 : }
5380 :
5381 63 : if (matrix_a->rank == 1 && matrix_b->rank == 2)
5382 : {
5383 7 : result_rows = 1;
5384 7 : result_columns = mpz_get_si (matrix_b->shape[1]);
5385 7 : stride_a = 1;
5386 7 : stride_b = mpz_get_si (matrix_b->shape[0]);
5387 :
5388 7 : result->rank = 1;
5389 7 : result->shape = gfc_get_shape (result->rank);
5390 7 : mpz_init_set_si (result->shape[0], result_columns);
5391 : }
5392 56 : else if (matrix_a->rank == 2 && matrix_b->rank == 1)
5393 : {
5394 6 : result_rows = mpz_get_si (matrix_a->shape[0]);
5395 6 : result_columns = 1;
5396 6 : stride_a = mpz_get_si (matrix_a->shape[0]);
5397 6 : stride_b = 1;
5398 :
5399 6 : result->rank = 1;
5400 6 : result->shape = gfc_get_shape (result->rank);
5401 6 : mpz_init_set_si (result->shape[0], result_rows);
5402 : }
5403 50 : else if (matrix_a->rank == 2 && matrix_b->rank == 2)
5404 : {
5405 50 : result_rows = mpz_get_si (matrix_a->shape[0]);
5406 50 : result_columns = mpz_get_si (matrix_b->shape[1]);
5407 50 : stride_a = mpz_get_si (matrix_a->shape[0]);
5408 50 : stride_b = mpz_get_si (matrix_b->shape[0]);
5409 :
5410 50 : result->rank = 2;
5411 50 : result->shape = gfc_get_shape (result->rank);
5412 50 : mpz_init_set_si (result->shape[0], result_rows);
5413 50 : mpz_init_set_si (result->shape[1], result_columns);
5414 : }
5415 : else
5416 0 : gcc_unreachable();
5417 :
5418 63 : offset_b = 0;
5419 223 : for (col = 0; col < result_columns; ++col)
5420 : {
5421 : offset_a = 0;
5422 :
5423 578 : for (row = 0; row < result_rows; ++row)
5424 : {
5425 418 : gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
5426 : matrix_b, 1, offset_b, false);
5427 418 : gfc_constructor_append_expr (&result->value.constructor,
5428 : e, NULL);
5429 :
5430 418 : offset_a += 1;
5431 : }
5432 :
5433 160 : offset_b += stride_b;
5434 : }
5435 :
5436 : return result;
5437 : }
5438 :
5439 :
5440 : gfc_expr *
5441 285 : gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
5442 : {
5443 285 : gfc_expr *result;
5444 285 : int kind, arg, k;
5445 :
5446 285 : if (i->expr_type != EXPR_CONSTANT)
5447 : return NULL;
5448 :
5449 213 : kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
5450 213 : if (kind == -1)
5451 : return &gfc_bad_expr;
5452 213 : k = gfc_validate_kind (BT_INTEGER, kind, false);
5453 :
5454 213 : bool fail = gfc_extract_int (i, &arg);
5455 213 : gcc_assert (!fail);
5456 :
5457 213 : if (!gfc_check_mask (i, kind_arg))
5458 : return &gfc_bad_expr;
5459 :
5460 211 : result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
5461 :
5462 : /* MASKR(n) = 2^n - 1 */
5463 211 : mpz_set_ui (result->value.integer, 1);
5464 211 : mpz_mul_2exp (result->value.integer, result->value.integer, arg);
5465 211 : mpz_sub_ui (result->value.integer, result->value.integer, 1);
5466 :
5467 211 : gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
5468 :
5469 211 : return result;
5470 : }
5471 :
5472 :
5473 : gfc_expr *
5474 297 : gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
5475 : {
5476 297 : gfc_expr *result;
5477 297 : int kind, arg, k;
5478 297 : mpz_t z;
5479 :
5480 297 : if (i->expr_type != EXPR_CONSTANT)
5481 : return NULL;
5482 :
5483 217 : kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
5484 217 : if (kind == -1)
5485 : return &gfc_bad_expr;
5486 217 : k = gfc_validate_kind (BT_INTEGER, kind, false);
5487 :
5488 217 : bool fail = gfc_extract_int (i, &arg);
5489 217 : gcc_assert (!fail);
5490 :
5491 217 : if (!gfc_check_mask (i, kind_arg))
5492 : return &gfc_bad_expr;
5493 :
5494 213 : result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
5495 :
5496 : /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
5497 213 : mpz_init_set_ui (z, 1);
5498 213 : mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
5499 213 : mpz_set_ui (result->value.integer, 1);
5500 213 : mpz_mul_2exp (result->value.integer, result->value.integer,
5501 213 : gfc_integer_kinds[k].bit_size - arg);
5502 213 : mpz_sub (result->value.integer, z, result->value.integer);
5503 213 : mpz_clear (z);
5504 :
5505 213 : gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
5506 :
5507 213 : return result;
5508 : }
5509 :
5510 : /* Similar to gfc_simplify_maskr, but code paths are different enough to make
5511 : this into a separate function. */
5512 :
5513 : gfc_expr *
5514 24 : gfc_simplify_umaskr (gfc_expr *i, gfc_expr *kind_arg)
5515 : {
5516 24 : gfc_expr *result;
5517 24 : int kind, arg, k;
5518 :
5519 24 : if (i->expr_type != EXPR_CONSTANT)
5520 : return NULL;
5521 :
5522 24 : kind = get_kind (BT_UNSIGNED, kind_arg, "UMASKR", gfc_default_unsigned_kind);
5523 24 : if (kind == -1)
5524 : return &gfc_bad_expr;
5525 24 : k = gfc_validate_kind (BT_UNSIGNED, kind, false);
5526 :
5527 24 : bool fail = gfc_extract_int (i, &arg);
5528 24 : gcc_assert (!fail);
5529 :
5530 24 : if (!gfc_check_mask (i, kind_arg))
5531 : return &gfc_bad_expr;
5532 :
5533 24 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &i->where);
5534 :
5535 : /* MASKR(n) = 2^n - 1 */
5536 24 : mpz_set_ui (result->value.integer, 1);
5537 24 : mpz_mul_2exp (result->value.integer, result->value.integer, arg);
5538 24 : mpz_sub_ui (result->value.integer, result->value.integer, 1);
5539 :
5540 24 : gfc_convert_mpz_to_unsigned (result->value.integer,
5541 : gfc_unsigned_kinds[k].bit_size,
5542 : false);
5543 :
5544 24 : return result;
5545 : }
5546 :
5547 : /* Likewise, similar to gfc_simplify_maskl. */
5548 :
5549 : gfc_expr *
5550 24 : gfc_simplify_umaskl (gfc_expr *i, gfc_expr *kind_arg)
5551 : {
5552 24 : gfc_expr *result;
5553 24 : int kind, arg, k;
5554 24 : mpz_t z;
5555 :
5556 24 : if (i->expr_type != EXPR_CONSTANT)
5557 : return NULL;
5558 :
5559 24 : kind = get_kind (BT_UNSIGNED, kind_arg, "UMASKL", gfc_default_integer_kind);
5560 24 : if (kind == -1)
5561 : return &gfc_bad_expr;
5562 24 : k = gfc_validate_kind (BT_UNSIGNED, kind, false);
5563 :
5564 24 : bool fail = gfc_extract_int (i, &arg);
5565 24 : gcc_assert (!fail);
5566 :
5567 24 : if (!gfc_check_mask (i, kind_arg))
5568 : return &gfc_bad_expr;
5569 :
5570 24 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &i->where);
5571 :
5572 : /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
5573 24 : mpz_init_set_ui (z, 1);
5574 24 : mpz_mul_2exp (z, z, gfc_unsigned_kinds[k].bit_size);
5575 24 : mpz_set_ui (result->value.integer, 1);
5576 24 : mpz_mul_2exp (result->value.integer, result->value.integer,
5577 24 : gfc_integer_kinds[k].bit_size - arg);
5578 24 : mpz_sub (result->value.integer, z, result->value.integer);
5579 24 : mpz_clear (z);
5580 :
5581 24 : gfc_convert_mpz_to_unsigned (result->value.integer,
5582 : gfc_unsigned_kinds[k].bit_size,
5583 : false);
5584 :
5585 24 : return result;
5586 : }
5587 :
5588 :
5589 : gfc_expr *
5590 4063 : gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
5591 : {
5592 4063 : gfc_expr * result;
5593 4063 : gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
5594 :
5595 4063 : if (mask->expr_type == EXPR_CONSTANT)
5596 : {
5597 : /* The standard requires evaluation of all function arguments.
5598 : Simplify only when the other dropped argument (FSOURCE or TSOURCE)
5599 : is a constant expression. */
5600 699 : if (mask->value.logical)
5601 : {
5602 482 : if (!gfc_is_constant_expr (fsource))
5603 : return NULL;
5604 168 : result = gfc_copy_expr (tsource);
5605 : }
5606 : else
5607 : {
5608 217 : if (!gfc_is_constant_expr (tsource))
5609 : return NULL;
5610 67 : result = gfc_copy_expr (fsource);
5611 : }
5612 :
5613 : /* Parenthesis is needed to get lower bounds of 1. */
5614 235 : result = gfc_get_parentheses (result);
5615 235 : gfc_simplify_expr (result, 1);
5616 235 : return result;
5617 : }
5618 :
5619 761 : if (!mask->rank || !is_constant_array_expr (mask)
5620 3411 : || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
5621 3345 : return NULL;
5622 :
5623 19 : result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
5624 : &tsource->where);
5625 19 : if (tsource->ts.type == BT_DERIVED)
5626 1 : result->ts.u.derived = tsource->ts.u.derived;
5627 18 : else if (tsource->ts.type == BT_CHARACTER)
5628 6 : result->ts.u.cl = tsource->ts.u.cl;
5629 :
5630 19 : tsource_ctor = gfc_constructor_first (tsource->value.constructor);
5631 19 : fsource_ctor = gfc_constructor_first (fsource->value.constructor);
5632 19 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5633 :
5634 87 : while (mask_ctor)
5635 : {
5636 49 : if (mask_ctor->expr->value.logical)
5637 31 : gfc_constructor_append_expr (&result->value.constructor,
5638 : gfc_copy_expr (tsource_ctor->expr),
5639 : NULL);
5640 : else
5641 18 : gfc_constructor_append_expr (&result->value.constructor,
5642 : gfc_copy_expr (fsource_ctor->expr),
5643 : NULL);
5644 49 : tsource_ctor = gfc_constructor_next (tsource_ctor);
5645 49 : fsource_ctor = gfc_constructor_next (fsource_ctor);
5646 49 : mask_ctor = gfc_constructor_next (mask_ctor);
5647 : }
5648 :
5649 19 : result->shape = gfc_get_shape (1);
5650 19 : gfc_array_size (result, &result->shape[0]);
5651 :
5652 19 : return result;
5653 : }
5654 :
5655 :
5656 : gfc_expr *
5657 390 : gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
5658 : {
5659 390 : mpz_t arg1, arg2, mask;
5660 390 : gfc_expr *result;
5661 :
5662 390 : if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
5663 294 : || mask_expr->expr_type != EXPR_CONSTANT)
5664 : return NULL;
5665 :
5666 294 : result = gfc_get_constant_expr (i->ts.type, i->ts.kind, &i->where);
5667 :
5668 : /* Convert all argument to unsigned. */
5669 294 : mpz_init_set (arg1, i->value.integer);
5670 294 : mpz_init_set (arg2, j->value.integer);
5671 294 : mpz_init_set (mask, mask_expr->value.integer);
5672 :
5673 : /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
5674 294 : mpz_and (arg1, arg1, mask);
5675 294 : mpz_com (mask, mask);
5676 294 : mpz_and (arg2, arg2, mask);
5677 294 : mpz_ior (result->value.integer, arg1, arg2);
5678 :
5679 294 : mpz_clear (arg1);
5680 294 : mpz_clear (arg2);
5681 294 : mpz_clear (mask);
5682 :
5683 294 : return result;
5684 : }
5685 :
5686 :
5687 : /* Selects between current value and extremum for simplify_min_max
5688 : and simplify_minval_maxval. */
5689 : static int
5690 3194 : min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
5691 : {
5692 3194 : int ret;
5693 :
5694 3194 : switch (arg->ts.type)
5695 : {
5696 2099 : case BT_INTEGER:
5697 2099 : case BT_UNSIGNED:
5698 2099 : if (extremum->ts.kind < arg->ts.kind)
5699 1 : extremum->ts.kind = arg->ts.kind;
5700 2099 : ret = mpz_cmp (arg->value.integer,
5701 2099 : extremum->value.integer) * sign;
5702 2099 : if (ret > 0)
5703 1277 : mpz_set (extremum->value.integer, arg->value.integer);
5704 : break;
5705 :
5706 598 : case BT_REAL:
5707 598 : if (extremum->ts.kind < arg->ts.kind)
5708 25 : extremum->ts.kind = arg->ts.kind;
5709 598 : if (mpfr_nan_p (extremum->value.real))
5710 : {
5711 192 : ret = 1;
5712 192 : mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
5713 : }
5714 406 : else if (mpfr_nan_p (arg->value.real))
5715 : ret = -1;
5716 : else
5717 : {
5718 286 : ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign;
5719 286 : if (ret > 0)
5720 140 : mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
5721 : }
5722 : break;
5723 :
5724 497 : case BT_CHARACTER:
5725 : #define LENGTH(x) ((x)->value.character.length)
5726 : #define STRING(x) ((x)->value.character.string)
5727 497 : if (LENGTH (extremum) < LENGTH(arg))
5728 : {
5729 12 : gfc_char_t *tmp = STRING(extremum);
5730 :
5731 12 : STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
5732 12 : memcpy (STRING(extremum), tmp,
5733 12 : LENGTH(extremum) * sizeof (gfc_char_t));
5734 12 : gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
5735 12 : LENGTH(arg) - LENGTH(extremum));
5736 12 : STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
5737 12 : LENGTH(extremum) = LENGTH(arg);
5738 12 : free (tmp);
5739 : }
5740 497 : ret = gfc_compare_string (arg, extremum) * sign;
5741 497 : if (ret > 0)
5742 : {
5743 187 : free (STRING(extremum));
5744 187 : STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
5745 187 : memcpy (STRING(extremum), STRING(arg),
5746 187 : LENGTH(arg) * sizeof (gfc_char_t));
5747 187 : gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
5748 187 : LENGTH(extremum) - LENGTH(arg));
5749 187 : STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
5750 : }
5751 : #undef LENGTH
5752 : #undef STRING
5753 : break;
5754 :
5755 0 : default:
5756 0 : gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5757 : }
5758 3194 : if (back_val && ret == 0)
5759 59 : ret = 1;
5760 :
5761 3194 : return ret;
5762 : }
5763 :
5764 :
5765 : /* This function is special since MAX() can take any number of
5766 : arguments. The simplified expression is a rewritten version of the
5767 : argument list containing at most one constant element. Other
5768 : constant elements are deleted. Because the argument list has
5769 : already been checked, this function always succeeds. sign is 1 for
5770 : MAX(), -1 for MIN(). */
5771 :
5772 : static gfc_expr *
5773 6112 : simplify_min_max (gfc_expr *expr, int sign)
5774 : {
5775 6112 : int tmp1, tmp2;
5776 6112 : gfc_actual_arglist *arg, *last, *extremum;
5777 6112 : gfc_expr *tmp, *ret;
5778 6112 : const char *fname;
5779 :
5780 6112 : last = NULL;
5781 6112 : extremum = NULL;
5782 :
5783 6112 : arg = expr->value.function.actual;
5784 :
5785 19612 : for (; arg; last = arg, arg = arg->next)
5786 : {
5787 13500 : if (arg->expr->expr_type != EXPR_CONSTANT)
5788 7953 : continue;
5789 :
5790 5547 : if (extremum == NULL)
5791 : {
5792 3484 : extremum = arg;
5793 3484 : continue;
5794 : }
5795 :
5796 2063 : min_max_choose (arg->expr, extremum->expr, sign);
5797 :
5798 : /* Delete the extra constant argument. */
5799 2063 : last->next = arg->next;
5800 :
5801 2063 : arg->next = NULL;
5802 2063 : gfc_free_actual_arglist (arg);
5803 2063 : arg = last;
5804 : }
5805 :
5806 : /* If there is one value left, replace the function call with the
5807 : expression. */
5808 6112 : if (expr->value.function.actual->next != NULL)
5809 : return NULL;
5810 :
5811 : /* Handle special cases of specific functions (min|max)1 and
5812 : a(min|max)0. */
5813 :
5814 1682 : tmp = expr->value.function.actual->expr;
5815 1682 : fname = expr->value.function.isym->name;
5816 :
5817 1682 : if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind)
5818 582 : && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0))
5819 : {
5820 : /* Explicit conversion, turn off -Wconversion and -Wconversion-extra
5821 : warnings. */
5822 15 : tmp1 = warn_conversion;
5823 15 : tmp2 = warn_conversion_extra;
5824 15 : warn_conversion = warn_conversion_extra = 0;
5825 :
5826 15 : ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind);
5827 :
5828 15 : warn_conversion = tmp1;
5829 15 : warn_conversion_extra = tmp2;
5830 : }
5831 1667 : else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind)
5832 1450 : && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0))
5833 : {
5834 15 : ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind);
5835 : }
5836 : else
5837 1652 : ret = gfc_copy_expr (tmp);
5838 :
5839 : return ret;
5840 :
5841 : }
5842 :
5843 :
5844 : gfc_expr *
5845 1987 : gfc_simplify_min (gfc_expr *e)
5846 : {
5847 1987 : return simplify_min_max (e, -1);
5848 : }
5849 :
5850 :
5851 : gfc_expr *
5852 4125 : gfc_simplify_max (gfc_expr *e)
5853 : {
5854 4125 : return simplify_min_max (e, 1);
5855 : }
5856 :
5857 : /* Helper function for gfc_simplify_minval. */
5858 :
5859 : static gfc_expr *
5860 295 : gfc_min (gfc_expr *op1, gfc_expr *op2)
5861 : {
5862 295 : min_max_choose (op1, op2, -1);
5863 295 : gfc_free_expr (op1);
5864 295 : return op2;
5865 : }
5866 :
5867 : /* Simplify minval for constant arrays. */
5868 :
5869 : gfc_expr *
5870 3981 : gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5871 : {
5872 3981 : return simplify_transformation (array, dim, mask, INT_MAX, gfc_min);
5873 : }
5874 :
5875 : /* Helper function for gfc_simplify_maxval. */
5876 :
5877 : static gfc_expr *
5878 271 : gfc_max (gfc_expr *op1, gfc_expr *op2)
5879 : {
5880 271 : min_max_choose (op1, op2, 1);
5881 271 : gfc_free_expr (op1);
5882 271 : return op2;
5883 : }
5884 :
5885 :
5886 : /* Simplify maxval for constant arrays. */
5887 :
5888 : gfc_expr *
5889 3013 : gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5890 : {
5891 3013 : return simplify_transformation (array, dim, mask, INT_MIN, gfc_max);
5892 : }
5893 :
5894 :
5895 : /* Transform minloc or maxloc of an array, according to MASK,
5896 : to the scalar result. This code is mostly identical to
5897 : simplify_transformation_to_scalar. */
5898 :
5899 : static gfc_expr *
5900 82 : simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
5901 : gfc_expr *extremum, int sign, bool back_val)
5902 : {
5903 82 : gfc_expr *a, *m;
5904 82 : gfc_constructor *array_ctor, *mask_ctor;
5905 82 : mpz_t count;
5906 :
5907 82 : mpz_set_si (result->value.integer, 0);
5908 :
5909 :
5910 : /* Shortcut for constant .FALSE. MASK. */
5911 82 : if (mask
5912 42 : && mask->expr_type == EXPR_CONSTANT
5913 36 : && !mask->value.logical)
5914 : return result;
5915 :
5916 46 : array_ctor = gfc_constructor_first (array->value.constructor);
5917 46 : if (mask && mask->expr_type == EXPR_ARRAY)
5918 6 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5919 : else
5920 : mask_ctor = NULL;
5921 :
5922 46 : mpz_init_set_si (count, 0);
5923 216 : while (array_ctor)
5924 : {
5925 124 : mpz_add_ui (count, count, 1);
5926 124 : a = array_ctor->expr;
5927 124 : array_ctor = gfc_constructor_next (array_ctor);
5928 : /* A constant MASK equals .TRUE. here and can be ignored. */
5929 124 : if (mask_ctor)
5930 : {
5931 28 : m = mask_ctor->expr;
5932 28 : mask_ctor = gfc_constructor_next (mask_ctor);
5933 28 : if (!m->value.logical)
5934 12 : continue;
5935 : }
5936 112 : if (min_max_choose (a, extremum, sign, back_val) > 0)
5937 60 : mpz_set (result->value.integer, count);
5938 : }
5939 46 : mpz_clear (count);
5940 46 : gfc_free_expr (extremum);
5941 46 : return result;
5942 : }
5943 :
5944 : /* Simplify minloc / maxloc in the absence of a dim argument. */
5945 :
5946 : static gfc_expr *
5947 69 : simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
5948 : gfc_expr *array, gfc_expr *mask, int sign,
5949 : bool back_val)
5950 : {
5951 69 : ssize_t res[GFC_MAX_DIMENSIONS];
5952 69 : int i, n;
5953 69 : gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5954 69 : ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5955 : sstride[GFC_MAX_DIMENSIONS];
5956 69 : gfc_expr *a, *m;
5957 69 : bool continue_loop;
5958 69 : bool ma;
5959 :
5960 154 : for (i = 0; i<array->rank; i++)
5961 85 : res[i] = -1;
5962 :
5963 : /* Shortcut for constant .FALSE. MASK. */
5964 69 : if (mask
5965 56 : && mask->expr_type == EXPR_CONSTANT
5966 40 : && !mask->value.logical)
5967 38 : goto finish;
5968 :
5969 31 : if (array->shape == NULL)
5970 1 : goto finish;
5971 :
5972 66 : for (i = 0; i < array->rank; i++)
5973 : {
5974 44 : count[i] = 0;
5975 44 : sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5976 44 : extent[i] = mpz_get_si (array->shape[i]);
5977 44 : if (extent[i] <= 0)
5978 8 : goto finish;
5979 : }
5980 :
5981 22 : continue_loop = true;
5982 22 : array_ctor = gfc_constructor_first (array->value.constructor);
5983 22 : if (mask && mask->rank > 0)
5984 12 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5985 : else
5986 : mask_ctor = NULL;
5987 :
5988 : /* Loop over the array elements (and mask), keeping track of
5989 : the indices to return. */
5990 66 : while (continue_loop)
5991 : {
5992 120 : do
5993 : {
5994 120 : a = array_ctor->expr;
5995 120 : if (mask_ctor)
5996 : {
5997 46 : m = mask_ctor->expr;
5998 46 : ma = m->value.logical;
5999 46 : mask_ctor = gfc_constructor_next (mask_ctor);
6000 : }
6001 : else
6002 : ma = true;
6003 :
6004 120 : if (ma && min_max_choose (a, extremum, sign, back_val) > 0)
6005 : {
6006 130 : for (i = 0; i<array->rank; i++)
6007 86 : res[i] = count[i];
6008 : }
6009 120 : array_ctor = gfc_constructor_next (array_ctor);
6010 120 : count[0] ++;
6011 120 : } while (count[0] != extent[0]);
6012 : n = 0;
6013 58 : do
6014 : {
6015 : /* When we get to the end of a dimension, reset it and increment
6016 : the next dimension. */
6017 58 : count[n] = 0;
6018 58 : n++;
6019 58 : if (n >= array->rank)
6020 : {
6021 : continue_loop = false;
6022 : break;
6023 : }
6024 : else
6025 36 : count[n] ++;
6026 36 : } while (count[n] == extent[n]);
6027 : }
6028 :
6029 22 : finish:
6030 69 : gfc_free_expr (extremum);
6031 69 : result_ctor = gfc_constructor_first (result->value.constructor);
6032 154 : for (i = 0; i<array->rank; i++)
6033 : {
6034 85 : gfc_expr *r_expr;
6035 85 : r_expr = result_ctor->expr;
6036 85 : mpz_set_si (r_expr->value.integer, res[i] + 1);
6037 85 : result_ctor = gfc_constructor_next (result_ctor);
6038 : }
6039 69 : return result;
6040 : }
6041 :
6042 : /* Helper function for gfc_simplify_minmaxloc - build an array
6043 : expression with n elements. */
6044 :
6045 : static gfc_expr *
6046 116 : new_array (bt type, int kind, int n, locus *where)
6047 : {
6048 116 : gfc_expr *result;
6049 116 : int i;
6050 :
6051 116 : result = gfc_get_array_expr (type, kind, where);
6052 116 : result->rank = 1;
6053 116 : result->shape = gfc_get_shape(1);
6054 116 : mpz_init_set_si (result->shape[0], n);
6055 401 : for (i = 0; i < n; i++)
6056 : {
6057 169 : gfc_constructor_append_expr (&result->value.constructor,
6058 : gfc_get_constant_expr (type, kind, where),
6059 : NULL);
6060 : }
6061 :
6062 116 : return result;
6063 : }
6064 :
6065 : /* Simplify minloc and maxloc. This code is mostly identical to
6066 : simplify_transformation_to_array. */
6067 :
6068 : static gfc_expr *
6069 48 : simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
6070 : gfc_expr *dim, gfc_expr *mask,
6071 : gfc_expr *extremum, int sign, bool back_val)
6072 : {
6073 48 : mpz_t size;
6074 48 : int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
6075 48 : gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
6076 48 : gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
6077 :
6078 48 : int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
6079 : sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
6080 : tmpstride[GFC_MAX_DIMENSIONS];
6081 :
6082 : /* Shortcut for constant .FALSE. MASK. */
6083 48 : if (mask
6084 10 : && mask->expr_type == EXPR_CONSTANT
6085 0 : && !mask->value.logical)
6086 : return result;
6087 :
6088 : /* Build an indexed table for array element expressions to minimize
6089 : linked-list traversal. Masked elements are set to NULL. */
6090 48 : gfc_array_size (array, &size);
6091 48 : arraysize = mpz_get_ui (size);
6092 48 : mpz_clear (size);
6093 :
6094 48 : arrayvec = XCNEWVEC (gfc_expr*, arraysize);
6095 :
6096 48 : array_ctor = gfc_constructor_first (array->value.constructor);
6097 48 : mask_ctor = NULL;
6098 48 : if (mask && mask->expr_type == EXPR_ARRAY)
6099 10 : mask_ctor = gfc_constructor_first (mask->value.constructor);
6100 :
6101 474 : for (i = 0; i < arraysize; ++i)
6102 : {
6103 426 : arrayvec[i] = array_ctor->expr;
6104 426 : array_ctor = gfc_constructor_next (array_ctor);
6105 :
6106 426 : if (mask_ctor)
6107 : {
6108 106 : if (!mask_ctor->expr->value.logical)
6109 65 : arrayvec[i] = NULL;
6110 :
6111 106 : mask_ctor = gfc_constructor_next (mask_ctor);
6112 : }
6113 : }
6114 :
6115 : /* Same for the result expression. */
6116 48 : gfc_array_size (result, &size);
6117 48 : resultsize = mpz_get_ui (size);
6118 48 : mpz_clear (size);
6119 :
6120 48 : resultvec = XCNEWVEC (gfc_expr*, resultsize);
6121 48 : result_ctor = gfc_constructor_first (result->value.constructor);
6122 234 : for (i = 0; i < resultsize; ++i)
6123 : {
6124 138 : resultvec[i] = result_ctor->expr;
6125 138 : result_ctor = gfc_constructor_next (result_ctor);
6126 : }
6127 :
6128 48 : gfc_extract_int (dim, &dim_index);
6129 48 : dim_index -= 1; /* zero-base index */
6130 48 : dim_extent = 0;
6131 48 : dim_stride = 0;
6132 :
6133 144 : for (i = 0, n = 0; i < array->rank; ++i)
6134 : {
6135 96 : count[i] = 0;
6136 96 : tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
6137 96 : if (i == dim_index)
6138 : {
6139 48 : dim_extent = mpz_get_si (array->shape[i]);
6140 48 : dim_stride = tmpstride[i];
6141 48 : continue;
6142 : }
6143 :
6144 48 : extent[n] = mpz_get_si (array->shape[i]);
6145 48 : sstride[n] = tmpstride[i];
6146 48 : dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
6147 48 : n += 1;
6148 : }
6149 :
6150 48 : done = resultsize <= 0;
6151 48 : base = arrayvec;
6152 48 : dest = resultvec;
6153 234 : while (!done)
6154 : {
6155 138 : gfc_expr *ex;
6156 138 : ex = gfc_copy_expr (extremum);
6157 702 : for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
6158 : {
6159 426 : if (*src && min_max_choose (*src, ex, sign, back_val) > 0)
6160 215 : mpz_set_si ((*dest)->value.integer, n + 1);
6161 : }
6162 :
6163 138 : count[0]++;
6164 138 : base += sstride[0];
6165 138 : dest += dstride[0];
6166 138 : gfc_free_expr (ex);
6167 :
6168 138 : n = 0;
6169 276 : while (!done && count[n] == extent[n])
6170 : {
6171 46 : count[n] = 0;
6172 46 : base -= sstride[n] * extent[n];
6173 46 : dest -= dstride[n] * extent[n];
6174 :
6175 46 : n++;
6176 46 : if (n < result->rank)
6177 : {
6178 : /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
6179 : times, we'd warn for the last iteration, because the
6180 : array index will have already been incremented to the
6181 : array sizes, and we can't tell that this must make
6182 : the test against result->rank false, because ranks
6183 : must not exceed GFC_MAX_DIMENSIONS. */
6184 0 : GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
6185 0 : count[n]++;
6186 0 : base += sstride[n];
6187 0 : dest += dstride[n];
6188 0 : GCC_DIAGNOSTIC_POP
6189 : }
6190 : else
6191 : done = true;
6192 : }
6193 : }
6194 :
6195 : /* Place updated expression in result constructor. */
6196 48 : result_ctor = gfc_constructor_first (result->value.constructor);
6197 234 : for (i = 0; i < resultsize; ++i)
6198 : {
6199 138 : result_ctor->expr = resultvec[i];
6200 138 : result_ctor = gfc_constructor_next (result_ctor);
6201 : }
6202 :
6203 48 : free (arrayvec);
6204 48 : free (resultvec);
6205 48 : free (extremum);
6206 48 : return result;
6207 : }
6208 :
6209 : /* Simplify minloc and maxloc for constant arrays. */
6210 :
6211 : static gfc_expr *
6212 20917 : gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
6213 : gfc_expr *kind, gfc_expr *back, int sign)
6214 : {
6215 20917 : gfc_expr *result;
6216 20917 : gfc_expr *extremum;
6217 20917 : int ikind;
6218 20917 : int init_val;
6219 20917 : bool back_val = false;
6220 :
6221 20917 : if (!is_constant_array_expr (array)
6222 20917 : || !gfc_is_constant_expr (dim))
6223 20610 : return NULL;
6224 :
6225 307 : if (mask
6226 216 : && !is_constant_array_expr (mask)
6227 491 : && mask->expr_type != EXPR_CONSTANT)
6228 : return NULL;
6229 :
6230 199 : if (kind)
6231 : {
6232 0 : if (gfc_extract_int (kind, &ikind, -1))
6233 : return NULL;
6234 : }
6235 : else
6236 199 : ikind = gfc_default_integer_kind;
6237 :
6238 199 : if (back)
6239 : {
6240 199 : if (back->expr_type != EXPR_CONSTANT)
6241 : return NULL;
6242 :
6243 199 : back_val = back->value.logical;
6244 : }
6245 :
6246 199 : if (sign < 0)
6247 : init_val = INT_MAX;
6248 101 : else if (sign > 0)
6249 : init_val = INT_MIN;
6250 : else
6251 0 : gcc_unreachable();
6252 :
6253 199 : extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
6254 199 : init_result_expr (extremum, init_val, array);
6255 :
6256 199 : if (dim)
6257 : {
6258 130 : result = transformational_result (array, dim, BT_INTEGER,
6259 : ikind, &array->where);
6260 130 : init_result_expr (result, 0, array);
6261 :
6262 130 : if (array->rank == 1)
6263 82 : return simplify_minmaxloc_to_scalar (result, array, mask, extremum,
6264 82 : sign, back_val);
6265 : else
6266 48 : return simplify_minmaxloc_to_array (result, array, dim, mask, extremum,
6267 48 : sign, back_val);
6268 : }
6269 : else
6270 : {
6271 69 : result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
6272 69 : return simplify_minmaxloc_nodim (result, extremum, array, mask,
6273 69 : sign, back_val);
6274 : }
6275 : }
6276 :
6277 : gfc_expr *
6278 11240 : gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
6279 : gfc_expr *back)
6280 : {
6281 11240 : return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1);
6282 : }
6283 :
6284 : gfc_expr *
6285 9677 : gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
6286 : gfc_expr *back)
6287 : {
6288 9677 : return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
6289 : }
6290 :
6291 : /* Simplify findloc to scalar. Similar to
6292 : simplify_minmaxloc_to_scalar. */
6293 :
6294 : static gfc_expr *
6295 50 : simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
6296 : gfc_expr *mask, int back_val)
6297 : {
6298 50 : gfc_expr *a, *m;
6299 50 : gfc_constructor *array_ctor, *mask_ctor;
6300 50 : mpz_t count;
6301 :
6302 50 : mpz_set_si (result->value.integer, 0);
6303 :
6304 : /* Shortcut for constant .FALSE. MASK. */
6305 50 : if (mask
6306 14 : && mask->expr_type == EXPR_CONSTANT
6307 0 : && !mask->value.logical)
6308 : return result;
6309 :
6310 50 : array_ctor = gfc_constructor_first (array->value.constructor);
6311 50 : if (mask && mask->expr_type == EXPR_ARRAY)
6312 14 : mask_ctor = gfc_constructor_first (mask->value.constructor);
6313 : else
6314 : mask_ctor = NULL;
6315 :
6316 50 : mpz_init_set_si (count, 0);
6317 227 : while (array_ctor)
6318 : {
6319 156 : mpz_add_ui (count, count, 1);
6320 156 : a = array_ctor->expr;
6321 156 : array_ctor = gfc_constructor_next (array_ctor);
6322 : /* A constant MASK equals .TRUE. here and can be ignored. */
6323 156 : if (mask_ctor)
6324 : {
6325 56 : m = mask_ctor->expr;
6326 56 : mask_ctor = gfc_constructor_next (mask_ctor);
6327 56 : if (!m->value.logical)
6328 14 : continue;
6329 : }
6330 142 : if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
6331 : {
6332 : /* We have a match. If BACK is true, continue so we find
6333 : the last one. */
6334 50 : mpz_set (result->value.integer, count);
6335 50 : if (!back_val)
6336 : break;
6337 : }
6338 : }
6339 50 : mpz_clear (count);
6340 50 : return result;
6341 : }
6342 :
6343 : /* Simplify findloc in the absence of a dim argument. Similar to
6344 : simplify_minmaxloc_nodim. */
6345 :
6346 : static gfc_expr *
6347 47 : simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
6348 : gfc_expr *mask, bool back_val)
6349 : {
6350 47 : ssize_t res[GFC_MAX_DIMENSIONS];
6351 47 : int i, n;
6352 47 : gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
6353 47 : ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
6354 : sstride[GFC_MAX_DIMENSIONS];
6355 47 : gfc_expr *a, *m;
6356 47 : bool continue_loop;
6357 47 : bool ma;
6358 :
6359 131 : for (i = 0; i < array->rank; i++)
6360 84 : res[i] = -1;
6361 :
6362 : /* Shortcut for constant .FALSE. MASK. */
6363 47 : if (mask
6364 7 : && mask->expr_type == EXPR_CONSTANT
6365 0 : && !mask->value.logical)
6366 0 : goto finish;
6367 :
6368 125 : for (i = 0; i < array->rank; i++)
6369 : {
6370 84 : count[i] = 0;
6371 84 : sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
6372 84 : extent[i] = mpz_get_si (array->shape[i]);
6373 84 : if (extent[i] <= 0)
6374 6 : goto finish;
6375 : }
6376 :
6377 41 : continue_loop = true;
6378 41 : array_ctor = gfc_constructor_first (array->value.constructor);
6379 41 : if (mask && mask->rank > 0)
6380 7 : mask_ctor = gfc_constructor_first (mask->value.constructor);
6381 : else
6382 : mask_ctor = NULL;
6383 :
6384 : /* Loop over the array elements (and mask), keeping track of
6385 : the indices to return. */
6386 93 : while (continue_loop)
6387 : {
6388 138 : do
6389 : {
6390 138 : a = array_ctor->expr;
6391 138 : if (mask_ctor)
6392 : {
6393 28 : m = mask_ctor->expr;
6394 28 : ma = m->value.logical;
6395 28 : mask_ctor = gfc_constructor_next (mask_ctor);
6396 : }
6397 : else
6398 : ma = true;
6399 :
6400 138 : if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
6401 : {
6402 73 : for (i = 0; i < array->rank; i++)
6403 48 : res[i] = count[i];
6404 25 : if (!back_val)
6405 17 : goto finish;
6406 : }
6407 121 : array_ctor = gfc_constructor_next (array_ctor);
6408 121 : count[0] ++;
6409 121 : } while (count[0] != extent[0]);
6410 : n = 0;
6411 73 : do
6412 : {
6413 : /* When we get to the end of a dimension, reset it and increment
6414 : the next dimension. */
6415 73 : count[n] = 0;
6416 73 : n++;
6417 73 : if (n >= array->rank)
6418 : {
6419 : continue_loop = false;
6420 : break;
6421 : }
6422 : else
6423 49 : count[n] ++;
6424 49 : } while (count[n] == extent[n]);
6425 : }
6426 :
6427 24 : finish:
6428 47 : result_ctor = gfc_constructor_first (result->value.constructor);
6429 131 : for (i = 0; i < array->rank; i++)
6430 : {
6431 84 : gfc_expr *r_expr;
6432 84 : r_expr = result_ctor->expr;
6433 84 : mpz_set_si (r_expr->value.integer, res[i] + 1);
6434 84 : result_ctor = gfc_constructor_next (result_ctor);
6435 : }
6436 47 : return result;
6437 : }
6438 :
6439 :
6440 : /* Simplify findloc to an array. Similar to
6441 : simplify_minmaxloc_to_array. */
6442 :
6443 : static gfc_expr *
6444 14 : simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
6445 : gfc_expr *dim, gfc_expr *mask, bool back_val)
6446 : {
6447 14 : mpz_t size;
6448 14 : int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
6449 14 : gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
6450 14 : gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
6451 :
6452 14 : int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
6453 : sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
6454 : tmpstride[GFC_MAX_DIMENSIONS];
6455 :
6456 : /* Shortcut for constant .FALSE. MASK. */
6457 14 : if (mask
6458 0 : && mask->expr_type == EXPR_CONSTANT
6459 0 : && !mask->value.logical)
6460 : return result;
6461 :
6462 : /* Build an indexed table for array element expressions to minimize
6463 : linked-list traversal. Masked elements are set to NULL. */
6464 14 : gfc_array_size (array, &size);
6465 14 : arraysize = mpz_get_ui (size);
6466 14 : mpz_clear (size);
6467 :
6468 14 : arrayvec = XCNEWVEC (gfc_expr*, arraysize);
6469 :
6470 14 : array_ctor = gfc_constructor_first (array->value.constructor);
6471 14 : mask_ctor = NULL;
6472 14 : if (mask && mask->expr_type == EXPR_ARRAY)
6473 0 : mask_ctor = gfc_constructor_first (mask->value.constructor);
6474 :
6475 98 : for (i = 0; i < arraysize; ++i)
6476 : {
6477 84 : arrayvec[i] = array_ctor->expr;
6478 84 : array_ctor = gfc_constructor_next (array_ctor);
6479 :
6480 84 : if (mask_ctor)
6481 : {
6482 0 : if (!mask_ctor->expr->value.logical)
6483 0 : arrayvec[i] = NULL;
6484 :
6485 0 : mask_ctor = gfc_constructor_next (mask_ctor);
6486 : }
6487 : }
6488 :
6489 : /* Same for the result expression. */
6490 14 : gfc_array_size (result, &size);
6491 14 : resultsize = mpz_get_ui (size);
6492 14 : mpz_clear (size);
6493 :
6494 14 : resultvec = XCNEWVEC (gfc_expr*, resultsize);
6495 14 : result_ctor = gfc_constructor_first (result->value.constructor);
6496 63 : for (i = 0; i < resultsize; ++i)
6497 : {
6498 35 : resultvec[i] = result_ctor->expr;
6499 35 : result_ctor = gfc_constructor_next (result_ctor);
6500 : }
6501 :
6502 14 : gfc_extract_int (dim, &dim_index);
6503 :
6504 14 : dim_index -= 1; /* Zero-base index. */
6505 14 : dim_extent = 0;
6506 14 : dim_stride = 0;
6507 :
6508 42 : for (i = 0, n = 0; i < array->rank; ++i)
6509 : {
6510 28 : count[i] = 0;
6511 28 : tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
6512 28 : if (i == dim_index)
6513 : {
6514 14 : dim_extent = mpz_get_si (array->shape[i]);
6515 14 : dim_stride = tmpstride[i];
6516 14 : continue;
6517 : }
6518 :
6519 14 : extent[n] = mpz_get_si (array->shape[i]);
6520 14 : sstride[n] = tmpstride[i];
6521 14 : dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
6522 14 : n += 1;
6523 : }
6524 :
6525 14 : done = resultsize <= 0;
6526 14 : base = arrayvec;
6527 14 : dest = resultvec;
6528 63 : while (!done)
6529 : {
6530 63 : for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
6531 : {
6532 56 : if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
6533 : {
6534 28 : mpz_set_si ((*dest)->value.integer, n + 1);
6535 28 : if (!back_val)
6536 : break;
6537 : }
6538 : }
6539 :
6540 35 : count[0]++;
6541 35 : base += sstride[0];
6542 35 : dest += dstride[0];
6543 :
6544 35 : n = 0;
6545 35 : while (!done && count[n] == extent[n])
6546 : {
6547 14 : count[n] = 0;
6548 14 : base -= sstride[n] * extent[n];
6549 14 : dest -= dstride[n] * extent[n];
6550 :
6551 14 : n++;
6552 14 : if (n < result->rank)
6553 : {
6554 : /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
6555 : times, we'd warn for the last iteration, because the
6556 : array index will have already been incremented to the
6557 : array sizes, and we can't tell that this must make
6558 : the test against result->rank false, because ranks
6559 : must not exceed GFC_MAX_DIMENSIONS. */
6560 0 : GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
6561 0 : count[n]++;
6562 0 : base += sstride[n];
6563 0 : dest += dstride[n];
6564 0 : GCC_DIAGNOSTIC_POP
6565 : }
6566 : else
6567 : done = true;
6568 : }
6569 : }
6570 :
6571 : /* Place updated expression in result constructor. */
6572 14 : result_ctor = gfc_constructor_first (result->value.constructor);
6573 63 : for (i = 0; i < resultsize; ++i)
6574 : {
6575 35 : result_ctor->expr = resultvec[i];
6576 35 : result_ctor = gfc_constructor_next (result_ctor);
6577 : }
6578 :
6579 14 : free (arrayvec);
6580 14 : free (resultvec);
6581 14 : return result;
6582 : }
6583 :
6584 : /* Simplify findloc. */
6585 :
6586 : gfc_expr *
6587 1380 : gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
6588 : gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
6589 : {
6590 1380 : gfc_expr *result;
6591 1380 : int ikind;
6592 1380 : bool back_val = false;
6593 :
6594 1380 : if (!is_constant_array_expr (array)
6595 114 : || array->shape == NULL
6596 1493 : || !gfc_is_constant_expr (dim))
6597 1267 : return NULL;
6598 :
6599 113 : if (! gfc_is_constant_expr (value))
6600 : return 0;
6601 :
6602 113 : if (mask
6603 21 : && !is_constant_array_expr (mask)
6604 113 : && mask->expr_type != EXPR_CONSTANT)
6605 : return NULL;
6606 :
6607 113 : if (kind)
6608 : {
6609 0 : if (gfc_extract_int (kind, &ikind, -1))
6610 : return NULL;
6611 : }
6612 : else
6613 113 : ikind = gfc_default_integer_kind;
6614 :
6615 113 : if (back)
6616 : {
6617 113 : if (back->expr_type != EXPR_CONSTANT)
6618 : return NULL;
6619 :
6620 111 : back_val = back->value.logical;
6621 : }
6622 :
6623 111 : if (dim)
6624 : {
6625 64 : result = transformational_result (array, dim, BT_INTEGER,
6626 : ikind, &array->where);
6627 64 : init_result_expr (result, 0, array);
6628 :
6629 64 : if (array->rank == 1)
6630 50 : return simplify_findloc_to_scalar (result, array, value, mask,
6631 50 : back_val);
6632 : else
6633 14 : return simplify_findloc_to_array (result, array, value, dim, mask,
6634 14 : back_val);
6635 : }
6636 : else
6637 : {
6638 47 : result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
6639 47 : return simplify_findloc_nodim (result, value, array, mask, back_val);
6640 : }
6641 : return NULL;
6642 : }
6643 :
6644 : gfc_expr *
6645 1 : gfc_simplify_maxexponent (gfc_expr *x)
6646 : {
6647 1 : int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6648 1 : return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
6649 1 : gfc_real_kinds[i].max_exponent);
6650 : }
6651 :
6652 :
6653 : gfc_expr *
6654 25 : gfc_simplify_minexponent (gfc_expr *x)
6655 : {
6656 25 : int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6657 25 : return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
6658 25 : gfc_real_kinds[i].min_exponent);
6659 : }
6660 :
6661 :
6662 : gfc_expr *
6663 267104 : gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
6664 : {
6665 267104 : gfc_expr *result;
6666 267104 : int kind;
6667 :
6668 : /* First check p. */
6669 267104 : if (p->expr_type != EXPR_CONSTANT)
6670 : return NULL;
6671 :
6672 : /* p shall not be 0. */
6673 266239 : switch (p->ts.type)
6674 : {
6675 266131 : case BT_INTEGER:
6676 266131 : case BT_UNSIGNED:
6677 266131 : if (mpz_cmp_ui (p->value.integer, 0) == 0)
6678 : {
6679 4 : gfc_error ("Argument %qs of MOD at %L shall not be zero",
6680 : "P", &p->where);
6681 4 : return &gfc_bad_expr;
6682 : }
6683 : break;
6684 108 : case BT_REAL:
6685 108 : if (mpfr_cmp_ui (p->value.real, 0) == 0)
6686 : {
6687 0 : gfc_error ("Argument %qs of MOD at %L shall not be zero",
6688 : "P", &p->where);
6689 0 : return &gfc_bad_expr;
6690 : }
6691 : break;
6692 0 : default:
6693 0 : gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6694 : }
6695 :
6696 266235 : if (a->expr_type != EXPR_CONSTANT)
6697 : return NULL;
6698 :
6699 262824 : kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6700 262824 : result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6701 :
6702 262824 : if (a->ts.type == BT_INTEGER || a->ts.type == BT_UNSIGNED)
6703 262716 : mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
6704 : else
6705 : {
6706 108 : gfc_set_model_kind (kind);
6707 108 : mpfr_fmod (result->value.real, a->value.real, p->value.real,
6708 : GFC_RND_MODE);
6709 : }
6710 :
6711 262824 : return range_check (result, "MOD");
6712 : }
6713 :
6714 :
6715 : gfc_expr *
6716 1934 : gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
6717 : {
6718 1934 : gfc_expr *result;
6719 1934 : int kind;
6720 :
6721 : /* First check p. */
6722 1934 : if (p->expr_type != EXPR_CONSTANT)
6723 : return NULL;
6724 :
6725 : /* p shall not be 0. */
6726 1743 : switch (p->ts.type)
6727 : {
6728 1707 : case BT_INTEGER:
6729 1707 : case BT_UNSIGNED:
6730 1707 : if (mpz_cmp_ui (p->value.integer, 0) == 0)
6731 : {
6732 4 : gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6733 : "P", &p->where);
6734 4 : return &gfc_bad_expr;
6735 : }
6736 : break;
6737 36 : case BT_REAL:
6738 36 : if (mpfr_cmp_ui (p->value.real, 0) == 0)
6739 : {
6740 0 : gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6741 : "P", &p->where);
6742 0 : return &gfc_bad_expr;
6743 : }
6744 : break;
6745 0 : default:
6746 0 : gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6747 : }
6748 :
6749 1739 : if (a->expr_type != EXPR_CONSTANT)
6750 : return NULL;
6751 :
6752 252 : kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6753 252 : result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6754 :
6755 252 : if (a->ts.type == BT_INTEGER || a->ts.type == BT_UNSIGNED)
6756 216 : mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
6757 : else
6758 : {
6759 36 : gfc_set_model_kind (kind);
6760 36 : mpfr_fmod (result->value.real, a->value.real, p->value.real,
6761 : GFC_RND_MODE);
6762 36 : if (mpfr_cmp_ui (result->value.real, 0) != 0)
6763 : {
6764 12 : if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
6765 6 : mpfr_add (result->value.real, result->value.real, p->value.real,
6766 : GFC_RND_MODE);
6767 : }
6768 : else
6769 24 : mpfr_copysign (result->value.real, result->value.real,
6770 : p->value.real, GFC_RND_MODE);
6771 : }
6772 :
6773 252 : return range_check (result, "MODULO");
6774 : }
6775 :
6776 :
6777 : gfc_expr *
6778 6325 : gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
6779 : {
6780 6325 : gfc_expr *result;
6781 6325 : mpfr_exp_t emin, emax;
6782 6325 : int kind;
6783 :
6784 6325 : if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
6785 : return NULL;
6786 :
6787 891 : result = gfc_copy_expr (x);
6788 :
6789 : /* Save current values of emin and emax. */
6790 891 : emin = mpfr_get_emin ();
6791 891 : emax = mpfr_get_emax ();
6792 :
6793 : /* Set emin and emax for the current model number. */
6794 891 : kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
6795 891 : mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent -
6796 891 : mpfr_get_prec(result->value.real) + 1);
6797 891 : mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent);
6798 891 : mpfr_check_range (result->value.real, 0, MPFR_RNDU);
6799 :
6800 891 : if (mpfr_sgn (s->value.real) > 0)
6801 : {
6802 414 : mpfr_nextabove (result->value.real);
6803 414 : mpfr_subnormalize (result->value.real, 0, MPFR_RNDU);
6804 : }
6805 : else
6806 : {
6807 477 : mpfr_nextbelow (result->value.real);
6808 477 : mpfr_subnormalize (result->value.real, 0, MPFR_RNDD);
6809 : }
6810 :
6811 891 : mpfr_set_emin (emin);
6812 891 : mpfr_set_emax (emax);
6813 :
6814 : /* Only NaN can occur. Do not use range check as it gives an
6815 : error for denormal numbers. */
6816 891 : if (mpfr_nan_p (result->value.real) && flag_range_check)
6817 : {
6818 0 : gfc_error ("Result of NEAREST is NaN at %L", &result->where);
6819 0 : gfc_free_expr (result);
6820 0 : return &gfc_bad_expr;
6821 : }
6822 :
6823 : return result;
6824 : }
6825 :
6826 :
6827 : static gfc_expr *
6828 518 : simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
6829 : {
6830 518 : gfc_expr *itrunc, *result;
6831 518 : int kind;
6832 :
6833 518 : kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
6834 518 : if (kind == -1)
6835 : return &gfc_bad_expr;
6836 :
6837 518 : if (e->expr_type != EXPR_CONSTANT)
6838 : return NULL;
6839 :
6840 156 : itrunc = gfc_copy_expr (e);
6841 156 : mpfr_round (itrunc->value.real, e->value.real);
6842 :
6843 156 : result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
6844 156 : gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
6845 :
6846 156 : gfc_free_expr (itrunc);
6847 :
6848 156 : return range_check (result, name);
6849 : }
6850 :
6851 :
6852 : gfc_expr *
6853 331 : gfc_simplify_new_line (gfc_expr *e)
6854 : {
6855 331 : gfc_expr *result;
6856 :
6857 331 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
6858 331 : result->value.character.string[0] = '\n';
6859 :
6860 331 : return result;
6861 : }
6862 :
6863 :
6864 : gfc_expr *
6865 406 : gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
6866 : {
6867 406 : return simplify_nint ("NINT", e, k);
6868 : }
6869 :
6870 :
6871 : gfc_expr *
6872 112 : gfc_simplify_idnint (gfc_expr *e)
6873 : {
6874 112 : return simplify_nint ("IDNINT", e, NULL);
6875 : }
6876 :
6877 : static int norm2_scale;
6878 :
6879 : static gfc_expr *
6880 124 : norm2_add_squared (gfc_expr *result, gfc_expr *e)
6881 : {
6882 124 : mpfr_t tmp;
6883 :
6884 124 : gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6885 124 : gcc_assert (result->ts.type == BT_REAL
6886 : && result->expr_type == EXPR_CONSTANT);
6887 :
6888 124 : gfc_set_model_kind (result->ts.kind);
6889 124 : int index = gfc_validate_kind (BT_REAL, result->ts.kind, false);
6890 124 : mpfr_exp_t exp;
6891 124 : if (mpfr_regular_p (result->value.real))
6892 : {
6893 61 : exp = mpfr_get_exp (result->value.real);
6894 : /* If result is getting close to overflowing, scale down. */
6895 61 : if (exp >= gfc_real_kinds[index].max_exponent - 4
6896 0 : && norm2_scale <= gfc_real_kinds[index].max_exponent - 2)
6897 : {
6898 0 : norm2_scale += 2;
6899 0 : mpfr_div_ui (result->value.real, result->value.real, 16,
6900 : GFC_RND_MODE);
6901 : }
6902 : }
6903 :
6904 124 : mpfr_init (tmp);
6905 124 : if (mpfr_regular_p (e->value.real))
6906 : {
6907 88 : exp = mpfr_get_exp (e->value.real);
6908 : /* If e**2 would overflow or close to overflowing, scale down. */
6909 88 : if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2)
6910 : {
6911 12 : int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4;
6912 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6913 12 : mpfr_set_exp (tmp, new_scale - norm2_scale);
6914 12 : mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6915 12 : mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6916 12 : norm2_scale = new_scale;
6917 : }
6918 : }
6919 124 : if (norm2_scale)
6920 : {
6921 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6922 12 : mpfr_set_exp (tmp, norm2_scale);
6923 12 : mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE);
6924 : }
6925 : else
6926 112 : mpfr_set (tmp, e->value.real, GFC_RND_MODE);
6927 124 : mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE);
6928 124 : mpfr_add (result->value.real, result->value.real, tmp,
6929 : GFC_RND_MODE);
6930 124 : mpfr_clear (tmp);
6931 :
6932 124 : return result;
6933 : }
6934 :
6935 :
6936 : static gfc_expr *
6937 2 : norm2_do_sqrt (gfc_expr *result, gfc_expr *e)
6938 : {
6939 2 : gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6940 2 : gcc_assert (result->ts.type == BT_REAL
6941 : && result->expr_type == EXPR_CONSTANT);
6942 :
6943 2 : if (result != e)
6944 0 : mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
6945 2 : mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6946 2 : if (norm2_scale && mpfr_regular_p (result->value.real))
6947 : {
6948 0 : mpfr_t tmp;
6949 0 : mpfr_init (tmp);
6950 0 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6951 0 : mpfr_set_exp (tmp, norm2_scale);
6952 0 : mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6953 0 : mpfr_clear (tmp);
6954 : }
6955 2 : norm2_scale = 0;
6956 :
6957 2 : return result;
6958 : }
6959 :
6960 :
6961 : gfc_expr *
6962 449 : gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
6963 : {
6964 449 : gfc_expr *result;
6965 449 : bool size_zero;
6966 :
6967 449 : size_zero = gfc_is_size_zero_array (e);
6968 :
6969 835 : if (!(is_constant_array_expr (e) || size_zero)
6970 449 : || (dim != NULL && !gfc_is_constant_expr (dim)))
6971 386 : return NULL;
6972 :
6973 63 : result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
6974 63 : init_result_expr (result, 0, NULL);
6975 :
6976 63 : if (size_zero)
6977 : return result;
6978 :
6979 38 : norm2_scale = 0;
6980 38 : if (!dim || e->rank == 1)
6981 : {
6982 37 : result = simplify_transformation_to_scalar (result, e, NULL,
6983 : norm2_add_squared);
6984 37 : mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6985 37 : if (norm2_scale && mpfr_regular_p (result->value.real))
6986 : {
6987 12 : mpfr_t tmp;
6988 12 : mpfr_init (tmp);
6989 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6990 12 : mpfr_set_exp (tmp, norm2_scale);
6991 12 : mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6992 12 : mpfr_clear (tmp);
6993 : }
6994 37 : norm2_scale = 0;
6995 37 : }
6996 : else
6997 1 : result = simplify_transformation_to_array (result, e, dim, NULL,
6998 : norm2_add_squared,
6999 : norm2_do_sqrt);
7000 :
7001 : return result;
7002 : }
7003 :
7004 :
7005 : gfc_expr *
7006 602 : gfc_simplify_not (gfc_expr *e)
7007 : {
7008 602 : gfc_expr *result;
7009 :
7010 602 : if (e->expr_type != EXPR_CONSTANT)
7011 : return NULL;
7012 :
7013 211 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
7014 211 : mpz_com (result->value.integer, e->value.integer);
7015 :
7016 211 : return range_check (result, "NOT");
7017 : }
7018 :
7019 :
7020 : gfc_expr *
7021 1965 : gfc_simplify_null (gfc_expr *mold)
7022 : {
7023 1965 : gfc_expr *result;
7024 :
7025 1965 : if (mold)
7026 : {
7027 564 : result = gfc_copy_expr (mold);
7028 564 : result->expr_type = EXPR_NULL;
7029 : }
7030 : else
7031 1401 : result = gfc_get_null_expr (NULL);
7032 :
7033 1965 : return result;
7034 : }
7035 :
7036 :
7037 : gfc_expr *
7038 2041 : gfc_simplify_num_images (gfc_expr *team_or_team_number ATTRIBUTE_UNUSED)
7039 : {
7040 2041 : gfc_expr *result;
7041 :
7042 2041 : if (flag_coarray == GFC_FCOARRAY_NONE)
7043 : {
7044 0 : gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
7045 : return &gfc_bad_expr;
7046 : }
7047 :
7048 2041 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
7049 : return NULL;
7050 :
7051 : /* FIXME: gfc_current_locus is wrong. */
7052 430 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
7053 : &gfc_current_locus);
7054 430 : mpz_set_si (result->value.integer, 1);
7055 :
7056 430 : return result;
7057 : }
7058 :
7059 :
7060 : gfc_expr *
7061 20 : gfc_simplify_or (gfc_expr *x, gfc_expr *y)
7062 : {
7063 20 : gfc_expr *result;
7064 20 : int kind;
7065 :
7066 20 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
7067 : return NULL;
7068 :
7069 6 : kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
7070 :
7071 6 : switch (x->ts.type)
7072 : {
7073 0 : case BT_INTEGER:
7074 0 : result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
7075 0 : mpz_ior (result->value.integer, x->value.integer, y->value.integer);
7076 0 : return range_check (result, "OR");
7077 :
7078 6 : case BT_LOGICAL:
7079 6 : return gfc_get_logical_expr (kind, &x->where,
7080 12 : x->value.logical || y->value.logical);
7081 0 : default:
7082 0 : gcc_unreachable();
7083 : }
7084 : }
7085 :
7086 :
7087 : gfc_expr *
7088 1602 : gfc_simplify_out_of_range (gfc_expr *x, gfc_expr *mold, gfc_expr *round)
7089 : {
7090 1602 : gfc_expr *result;
7091 1602 : mpfr_t a;
7092 1602 : mpz_t b;
7093 1602 : int i, k;
7094 1602 : bool res = false;
7095 1602 : bool rnd = false;
7096 :
7097 1602 : i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
7098 1602 : k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
7099 :
7100 1602 : mpfr_init (a);
7101 :
7102 1602 : switch (x->ts.type)
7103 : {
7104 1242 : case BT_REAL:
7105 1242 : if (mold->ts.type == BT_REAL)
7106 : {
7107 90 : if (mpfr_cmp (gfc_real_kinds[i].huge,
7108 : gfc_real_kinds[k].huge) <= 0)
7109 : {
7110 : /* Range of MOLD is always sufficient. */
7111 42 : res = false;
7112 42 : goto done;
7113 : }
7114 48 : else if (x->expr_type == EXPR_CONSTANT)
7115 : {
7116 0 : mpfr_neg (a, gfc_real_kinds[k].huge, GFC_RND_MODE);
7117 0 : res = (mpfr_cmp (x->value.real, a) < 0
7118 0 : || mpfr_cmp (x->value.real, gfc_real_kinds[k].huge) > 0);
7119 0 : goto done;
7120 : }
7121 : }
7122 1152 : else if (mold->ts.type == BT_INTEGER)
7123 : {
7124 582 : if (x->expr_type == EXPR_CONSTANT)
7125 : {
7126 48 : res = mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real);
7127 48 : if (res)
7128 0 : goto done;
7129 :
7130 48 : if (round && round->expr_type != EXPR_CONSTANT)
7131 : break;
7132 :
7133 24 : if (round && round->expr_type == EXPR_CONSTANT)
7134 24 : rnd = round->value.logical;
7135 :
7136 48 : if (rnd)
7137 24 : mpfr_round (a, x->value.real);
7138 : else
7139 24 : mpfr_trunc (a, x->value.real);
7140 :
7141 48 : mpz_init (b);
7142 48 : mpfr_get_z (b, a, GFC_RND_MODE);
7143 96 : res = (mpz_cmp (b, gfc_integer_kinds[k].min_int) < 0
7144 48 : || mpz_cmp (b, gfc_integer_kinds[k].huge) > 0);
7145 48 : mpz_clear (b);
7146 48 : goto done;
7147 : }
7148 : }
7149 570 : else if (mold->ts.type == BT_UNSIGNED)
7150 : {
7151 570 : if (x->expr_type == EXPR_CONSTANT)
7152 : {
7153 48 : res = mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real);
7154 48 : if (res)
7155 0 : goto done;
7156 :
7157 48 : if (round && round->expr_type != EXPR_CONSTANT)
7158 : break;
7159 :
7160 24 : if (round && round->expr_type == EXPR_CONSTANT)
7161 24 : rnd = round->value.logical;
7162 :
7163 24 : if (rnd)
7164 24 : mpfr_round (a, x->value.real);
7165 : else
7166 24 : mpfr_trunc (a, x->value.real);
7167 :
7168 48 : mpz_init (b);
7169 48 : mpfr_get_z (b, a, GFC_RND_MODE);
7170 96 : res = (mpz_cmp (b, gfc_unsigned_kinds[k].huge) > 0
7171 48 : || mpz_cmp_si (b, 0) < 0);
7172 48 : mpz_clear (b);
7173 48 : goto done;
7174 : }
7175 : }
7176 : break;
7177 :
7178 168 : case BT_INTEGER:
7179 168 : gcc_assert (round == NULL);
7180 168 : if (mold->ts.type == BT_INTEGER)
7181 : {
7182 54 : if (mpz_cmp (gfc_integer_kinds[i].huge,
7183 54 : gfc_integer_kinds[k].huge) <= 0)
7184 : {
7185 : /* Range of MOLD is always sufficient. */
7186 18 : res = false;
7187 18 : goto done;
7188 : }
7189 36 : else if (x->expr_type == EXPR_CONSTANT)
7190 : {
7191 0 : res = (mpz_cmp (x->value.integer,
7192 0 : gfc_integer_kinds[k].min_int) < 0
7193 0 : || mpz_cmp (x->value.integer,
7194 : gfc_integer_kinds[k].huge) > 0);
7195 0 : goto done;
7196 : }
7197 : }
7198 114 : else if (mold->ts.type == BT_UNSIGNED)
7199 : {
7200 90 : if (x->expr_type == EXPR_CONSTANT)
7201 : {
7202 0 : res = (mpz_cmp_si (x->value.integer, 0) < 0
7203 0 : || mpz_cmp (x->value.integer,
7204 0 : gfc_unsigned_kinds[k].huge) > 0);
7205 0 : goto done;
7206 : }
7207 : }
7208 24 : else if (mold->ts.type == BT_REAL)
7209 : {
7210 24 : mpfr_set_z (a, gfc_integer_kinds[i].min_int, GFC_RND_MODE);
7211 24 : mpfr_neg (a, a, GFC_RND_MODE);
7212 24 : res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
7213 : /* When false, range of MOLD is always sufficient. */
7214 24 : if (!res)
7215 24 : goto done;
7216 :
7217 0 : if (x->expr_type == EXPR_CONSTANT)
7218 : {
7219 0 : mpfr_set_z (a, x->value.integer, GFC_RND_MODE);
7220 0 : mpfr_abs (a, a, GFC_RND_MODE);
7221 0 : res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
7222 0 : goto done;
7223 : }
7224 : }
7225 : break;
7226 :
7227 192 : case BT_UNSIGNED:
7228 192 : gcc_assert (round == NULL);
7229 192 : if (mold->ts.type == BT_UNSIGNED)
7230 : {
7231 54 : if (mpz_cmp (gfc_unsigned_kinds[i].huge,
7232 54 : gfc_unsigned_kinds[k].huge) <= 0)
7233 : {
7234 : /* Range of MOLD is always sufficient. */
7235 18 : res = false;
7236 18 : goto done;
7237 : }
7238 36 : else if (x->expr_type == EXPR_CONSTANT)
7239 : {
7240 0 : res = mpz_cmp (x->value.integer,
7241 : gfc_unsigned_kinds[k].huge) > 0;
7242 0 : goto done;
7243 : }
7244 : }
7245 138 : else if (mold->ts.type == BT_INTEGER)
7246 : {
7247 60 : if (mpz_cmp (gfc_unsigned_kinds[i].huge,
7248 60 : gfc_integer_kinds[k].huge) <= 0)
7249 : {
7250 : /* Range of MOLD is always sufficient. */
7251 6 : res = false;
7252 6 : goto done;
7253 : }
7254 54 : else if (x->expr_type == EXPR_CONSTANT)
7255 : {
7256 0 : res = mpz_cmp (x->value.integer,
7257 : gfc_integer_kinds[k].huge) > 0;
7258 0 : goto done;
7259 : }
7260 : }
7261 78 : else if (mold->ts.type == BT_REAL)
7262 : {
7263 78 : mpfr_set_z (a, gfc_unsigned_kinds[i].huge, GFC_RND_MODE);
7264 78 : res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
7265 : /* When false, range of MOLD is always sufficient. */
7266 78 : if (!res)
7267 36 : goto done;
7268 :
7269 42 : if (x->expr_type == EXPR_CONSTANT)
7270 : {
7271 12 : mpfr_set_z (a, x->value.integer, GFC_RND_MODE);
7272 12 : res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
7273 12 : goto done;
7274 : }
7275 : }
7276 : break;
7277 :
7278 0 : default:
7279 0 : gcc_unreachable ();
7280 : }
7281 :
7282 1350 : mpfr_clear (a);
7283 :
7284 1350 : return NULL;
7285 :
7286 252 : done:
7287 252 : result = gfc_get_logical_expr (gfc_default_logical_kind, &x->where, res);
7288 :
7289 252 : mpfr_clear (a);
7290 :
7291 252 : return result;
7292 : }
7293 :
7294 :
7295 : gfc_expr *
7296 982 : gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
7297 : {
7298 982 : gfc_expr *result;
7299 982 : gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
7300 :
7301 982 : if (!is_constant_array_expr (array)
7302 58 : || !is_constant_array_expr (vector)
7303 1040 : || (!gfc_is_constant_expr (mask)
7304 2 : && !is_constant_array_expr (mask)))
7305 925 : return NULL;
7306 :
7307 57 : result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
7308 57 : if (array->ts.type == BT_DERIVED)
7309 5 : result->ts.u.derived = array->ts.u.derived;
7310 :
7311 57 : array_ctor = gfc_constructor_first (array->value.constructor);
7312 57 : vector_ctor = vector
7313 57 : ? gfc_constructor_first (vector->value.constructor)
7314 : : NULL;
7315 :
7316 57 : if (mask->expr_type == EXPR_CONSTANT
7317 0 : && mask->value.logical)
7318 : {
7319 : /* Copy all elements of ARRAY to RESULT. */
7320 0 : while (array_ctor)
7321 : {
7322 0 : gfc_constructor_append_expr (&result->value.constructor,
7323 : gfc_copy_expr (array_ctor->expr),
7324 : NULL);
7325 :
7326 0 : array_ctor = gfc_constructor_next (array_ctor);
7327 0 : vector_ctor = gfc_constructor_next (vector_ctor);
7328 : }
7329 : }
7330 57 : else if (mask->expr_type == EXPR_ARRAY)
7331 : {
7332 : /* Copy only those elements of ARRAY to RESULT whose
7333 : MASK equals .TRUE.. */
7334 57 : mask_ctor = gfc_constructor_first (mask->value.constructor);
7335 303 : while (mask_ctor && array_ctor)
7336 : {
7337 189 : if (mask_ctor->expr->value.logical)
7338 : {
7339 130 : gfc_constructor_append_expr (&result->value.constructor,
7340 : gfc_copy_expr (array_ctor->expr),
7341 : NULL);
7342 130 : vector_ctor = gfc_constructor_next (vector_ctor);
7343 : }
7344 :
7345 189 : array_ctor = gfc_constructor_next (array_ctor);
7346 189 : mask_ctor = gfc_constructor_next (mask_ctor);
7347 : }
7348 : }
7349 :
7350 : /* Append any left-over elements from VECTOR to RESULT. */
7351 85 : while (vector_ctor)
7352 : {
7353 28 : gfc_constructor_append_expr (&result->value.constructor,
7354 : gfc_copy_expr (vector_ctor->expr),
7355 : NULL);
7356 28 : vector_ctor = gfc_constructor_next (vector_ctor);
7357 : }
7358 :
7359 57 : result->shape = gfc_get_shape (1);
7360 57 : gfc_array_size (result, &result->shape[0]);
7361 :
7362 57 : if (array->ts.type == BT_CHARACTER)
7363 51 : result->ts.u.cl = array->ts.u.cl;
7364 :
7365 : return result;
7366 : }
7367 :
7368 :
7369 : static gfc_expr *
7370 124 : do_xor (gfc_expr *result, gfc_expr *e)
7371 : {
7372 124 : gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
7373 124 : gcc_assert (result->ts.type == BT_LOGICAL
7374 : && result->expr_type == EXPR_CONSTANT);
7375 :
7376 124 : result->value.logical = result->value.logical != e->value.logical;
7377 124 : return result;
7378 : }
7379 :
7380 :
7381 : gfc_expr *
7382 1166 : gfc_simplify_is_contiguous (gfc_expr *array)
7383 : {
7384 1166 : if (gfc_is_simply_contiguous (array, false, true))
7385 45 : return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);
7386 :
7387 1121 : if (gfc_is_not_contiguous (array))
7388 54 : return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
7389 :
7390 : return NULL;
7391 : }
7392 :
7393 :
7394 : gfc_expr *
7395 147 : gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
7396 : {
7397 147 : return simplify_transformation (e, dim, NULL, 0, do_xor);
7398 : }
7399 :
7400 :
7401 : gfc_expr *
7402 1064 : gfc_simplify_popcnt (gfc_expr *e)
7403 : {
7404 1064 : int res, k;
7405 1064 : mpz_t x;
7406 :
7407 1064 : if (e->expr_type != EXPR_CONSTANT)
7408 : return NULL;
7409 :
7410 642 : k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
7411 :
7412 642 : if (flag_unsigned && e->ts.type == BT_UNSIGNED)
7413 0 : res = mpz_popcount (e->value.integer);
7414 : else
7415 : {
7416 : /* Convert argument to unsigned, then count the '1' bits. */
7417 642 : mpz_init_set (x, e->value.integer);
7418 642 : gfc_convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
7419 642 : res = mpz_popcount (x);
7420 642 : mpz_clear (x);
7421 : }
7422 :
7423 642 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
7424 : }
7425 :
7426 :
7427 : gfc_expr *
7428 362 : gfc_simplify_poppar (gfc_expr *e)
7429 : {
7430 362 : gfc_expr *popcnt;
7431 362 : int i;
7432 :
7433 362 : if (e->expr_type != EXPR_CONSTANT)
7434 : return NULL;
7435 :
7436 300 : popcnt = gfc_simplify_popcnt (e);
7437 300 : gcc_assert (popcnt);
7438 :
7439 300 : bool fail = gfc_extract_int (popcnt, &i);
7440 300 : gcc_assert (!fail);
7441 :
7442 300 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
7443 : }
7444 :
7445 :
7446 : gfc_expr *
7447 465 : gfc_simplify_precision (gfc_expr *e)
7448 : {
7449 465 : int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
7450 465 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
7451 465 : gfc_real_kinds[i].precision);
7452 : }
7453 :
7454 :
7455 : gfc_expr *
7456 849 : gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
7457 : {
7458 849 : return simplify_transformation (array, dim, mask, 1, gfc_multiply);
7459 : }
7460 :
7461 :
7462 : gfc_expr *
7463 61 : gfc_simplify_radix (gfc_expr *e)
7464 : {
7465 61 : int i;
7466 61 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
7467 :
7468 61 : switch (e->ts.type)
7469 : {
7470 0 : case BT_INTEGER:
7471 0 : i = gfc_integer_kinds[i].radix;
7472 0 : break;
7473 :
7474 61 : case BT_REAL:
7475 61 : i = gfc_real_kinds[i].radix;
7476 61 : break;
7477 :
7478 0 : default:
7479 0 : gcc_unreachable ();
7480 : }
7481 :
7482 61 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
7483 : }
7484 :
7485 :
7486 : gfc_expr *
7487 185 : gfc_simplify_range (gfc_expr *e)
7488 : {
7489 185 : int i;
7490 185 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
7491 :
7492 185 : switch (e->ts.type)
7493 : {
7494 90 : case BT_INTEGER:
7495 90 : i = gfc_integer_kinds[i].range;
7496 90 : break;
7497 :
7498 24 : case BT_UNSIGNED:
7499 24 : i = gfc_unsigned_kinds[i].range;
7500 24 : break;
7501 :
7502 71 : case BT_REAL:
7503 71 : case BT_COMPLEX:
7504 71 : i = gfc_real_kinds[i].range;
7505 71 : break;
7506 :
7507 0 : default:
7508 0 : gcc_unreachable ();
7509 : }
7510 :
7511 185 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
7512 : }
7513 :
7514 :
7515 : gfc_expr *
7516 2101 : gfc_simplify_rank (gfc_expr *e)
7517 : {
7518 : /* Assumed rank. */
7519 2101 : if (e->rank == -1)
7520 : return NULL;
7521 :
7522 590 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
7523 : }
7524 :
7525 :
7526 : gfc_expr *
7527 30756 : gfc_simplify_real (gfc_expr *e, gfc_expr *k)
7528 : {
7529 30756 : gfc_expr *result = NULL;
7530 30756 : int kind, tmp1, tmp2;
7531 :
7532 : /* Convert BOZ to real, and return without range checking. */
7533 30756 : if (e->ts.type == BT_BOZ)
7534 : {
7535 : /* Determine kind for conversion of the BOZ. */
7536 85 : if (k)
7537 63 : gfc_extract_int (k, &kind);
7538 : else
7539 22 : kind = gfc_default_real_kind;
7540 :
7541 85 : if (!gfc_boz2real (e, kind))
7542 : return NULL;
7543 85 : result = gfc_copy_expr (e);
7544 85 : return result;
7545 : }
7546 :
7547 30671 : if (e->ts.type == BT_COMPLEX)
7548 2023 : kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
7549 : else
7550 28648 : kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
7551 :
7552 30671 : if (kind == -1)
7553 : return &gfc_bad_expr;
7554 :
7555 30671 : if (e->expr_type != EXPR_CONSTANT)
7556 : return NULL;
7557 :
7558 : /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
7559 : warnings. */
7560 24838 : tmp1 = warn_conversion;
7561 24838 : tmp2 = warn_conversion_extra;
7562 24838 : warn_conversion = warn_conversion_extra = 0;
7563 :
7564 24838 : result = gfc_convert_constant (e, BT_REAL, kind);
7565 :
7566 24838 : warn_conversion = tmp1;
7567 24838 : warn_conversion_extra = tmp2;
7568 :
7569 24838 : if (result == &gfc_bad_expr)
7570 : return &gfc_bad_expr;
7571 :
7572 24837 : return range_check (result, "REAL");
7573 : }
7574 :
7575 :
7576 : gfc_expr *
7577 7 : gfc_simplify_realpart (gfc_expr *e)
7578 : {
7579 7 : gfc_expr *result;
7580 :
7581 7 : if (e->expr_type != EXPR_CONSTANT)
7582 : return NULL;
7583 :
7584 1 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
7585 1 : mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
7586 :
7587 1 : return range_check (result, "REALPART");
7588 : }
7589 :
7590 : gfc_expr *
7591 2665 : gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
7592 : {
7593 2665 : gfc_expr *result;
7594 2665 : gfc_charlen_t len;
7595 2665 : mpz_t ncopies;
7596 2665 : bool have_length = false;
7597 :
7598 : /* If NCOPIES isn't a constant, there's nothing we can do. */
7599 2665 : if (n->expr_type != EXPR_CONSTANT)
7600 : return NULL;
7601 :
7602 : /* If NCOPIES is negative, it's an error. */
7603 2107 : if (mpz_sgn (n->value.integer) < 0)
7604 : {
7605 6 : gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
7606 : &n->where);
7607 6 : return &gfc_bad_expr;
7608 : }
7609 :
7610 : /* If we don't know the character length, we can do no more. */
7611 2101 : if (e->ts.u.cl && e->ts.u.cl->length
7612 426 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7613 : {
7614 426 : len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer);
7615 426 : have_length = true;
7616 : }
7617 1675 : else if (e->expr_type == EXPR_CONSTANT
7618 1675 : && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
7619 : {
7620 1675 : len = e->value.character.length;
7621 : }
7622 : else
7623 : return NULL;
7624 :
7625 : /* If the source length is 0, any value of NCOPIES is valid
7626 : and everything behaves as if NCOPIES == 0. */
7627 2101 : mpz_init (ncopies);
7628 2101 : if (len == 0)
7629 63 : mpz_set_ui (ncopies, 0);
7630 : else
7631 2038 : mpz_set (ncopies, n->value.integer);
7632 :
7633 : /* Check that NCOPIES isn't too large. */
7634 2101 : if (len)
7635 : {
7636 2038 : mpz_t max, mlen;
7637 2038 : int i;
7638 :
7639 : /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
7640 2038 : mpz_init (max);
7641 2038 : i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
7642 :
7643 2038 : if (have_length)
7644 : {
7645 369 : mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
7646 369 : e->ts.u.cl->length->value.integer);
7647 : }
7648 : else
7649 : {
7650 1669 : mpz_init (mlen);
7651 1669 : gfc_mpz_set_hwi (mlen, len);
7652 1669 : mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
7653 1669 : mpz_clear (mlen);
7654 : }
7655 :
7656 : /* The check itself. */
7657 2038 : if (mpz_cmp (ncopies, max) > 0)
7658 : {
7659 4 : mpz_clear (max);
7660 4 : mpz_clear (ncopies);
7661 4 : gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
7662 : &n->where);
7663 4 : return &gfc_bad_expr;
7664 : }
7665 :
7666 2034 : mpz_clear (max);
7667 : }
7668 2097 : mpz_clear (ncopies);
7669 :
7670 : /* For further simplification, we need the character string to be
7671 : constant. */
7672 2097 : if (e->expr_type != EXPR_CONSTANT)
7673 : return NULL;
7674 :
7675 1736 : HOST_WIDE_INT ncop;
7676 1736 : if (len ||
7677 42 : (e->ts.u.cl->length &&
7678 18 : mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
7679 : {
7680 1712 : bool fail = gfc_extract_hwi (n, &ncop);
7681 1712 : gcc_assert (!fail);
7682 : }
7683 : else
7684 24 : ncop = 0;
7685 :
7686 1736 : if (ncop == 0)
7687 54 : return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
7688 :
7689 1682 : len = e->value.character.length;
7690 1682 : gfc_charlen_t nlen = ncop * len;
7691 :
7692 : /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
7693 : (2**28 elements * 4 bytes (wide chars) per element) defer to
7694 : runtime instead of consuming (unbounded) memory and CPU at
7695 : compile time. */
7696 1682 : if (nlen > 268435456)
7697 : {
7698 1 : gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
7699 : " deferred to runtime, expect bugs", &e->where);
7700 1 : return NULL;
7701 : }
7702 :
7703 1681 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
7704 60344 : for (size_t i = 0; i < (size_t) ncop; i++)
7705 117656 : for (size_t j = 0; j < (size_t) len; j++)
7706 58993 : result->value.character.string[j+i*len]= e->value.character.string[j];
7707 :
7708 1681 : result->value.character.string[nlen] = '\0'; /* For debugger */
7709 1681 : return result;
7710 : }
7711 :
7712 :
7713 : /* This one is a bear, but mainly has to do with shuffling elements. */
7714 :
7715 : gfc_expr *
7716 9775 : gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
7717 : gfc_expr *pad, gfc_expr *order_exp)
7718 : {
7719 9775 : int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
7720 9775 : int i, rank, npad, x[GFC_MAX_DIMENSIONS];
7721 9775 : mpz_t index, size;
7722 9775 : unsigned long j;
7723 9775 : size_t nsource;
7724 9775 : gfc_expr *e, *result;
7725 9775 : bool zerosize = false;
7726 :
7727 : /* Check that argument expression types are OK. */
7728 9775 : if (!is_constant_array_expr (source)
7729 7957 : || !is_constant_array_expr (shape_exp)
7730 6637 : || !is_constant_array_expr (pad)
7731 16412 : || !is_constant_array_expr (order_exp))
7732 3150 : return NULL;
7733 :
7734 6625 : if (source->shape == NULL)
7735 : return NULL;
7736 :
7737 : /* Proceed with simplification, unpacking the array. */
7738 :
7739 6622 : mpz_init (index);
7740 6622 : rank = 0;
7741 :
7742 112574 : for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
7743 99330 : x[i] = 0;
7744 :
7745 37422 : for (;;)
7746 : {
7747 22022 : e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
7748 22022 : if (e == NULL)
7749 : break;
7750 :
7751 15400 : gfc_extract_int (e, &shape[rank]);
7752 :
7753 15400 : gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
7754 15400 : if (shape[rank] < 0)
7755 : {
7756 0 : gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
7757 : "negative value %d for dimension %d",
7758 : &shape_exp->where, shape[rank], rank+1);
7759 0 : mpz_clear (index);
7760 0 : return &gfc_bad_expr;
7761 : }
7762 :
7763 15400 : rank++;
7764 : }
7765 :
7766 6622 : gcc_assert (rank > 0);
7767 :
7768 : /* Now unpack the order array if present. */
7769 6622 : if (order_exp == NULL)
7770 : {
7771 21956 : for (i = 0; i < rank; i++)
7772 15356 : order[i] = i;
7773 : }
7774 : else
7775 : {
7776 22 : mpz_t size;
7777 22 : int order_size, shape_size;
7778 :
7779 22 : if (order_exp->rank != shape_exp->rank)
7780 : {
7781 1 : gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
7782 : &order_exp->where, &shape_exp->where);
7783 1 : mpz_clear (index);
7784 4 : return &gfc_bad_expr;
7785 : }
7786 :
7787 21 : gfc_array_size (shape_exp, &size);
7788 21 : shape_size = mpz_get_ui (size);
7789 21 : mpz_clear (size);
7790 21 : gfc_array_size (order_exp, &size);
7791 21 : order_size = mpz_get_ui (size);
7792 21 : mpz_clear (size);
7793 21 : if (order_size != shape_size)
7794 : {
7795 1 : gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
7796 : &order_exp->where, &shape_exp->where);
7797 1 : mpz_clear (index);
7798 1 : return &gfc_bad_expr;
7799 : }
7800 :
7801 58 : for (i = 0; i < rank; i++)
7802 : {
7803 40 : e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
7804 40 : gcc_assert (e);
7805 :
7806 40 : gfc_extract_int (e, &order[i]);
7807 :
7808 40 : if (order[i] < 1 || order[i] > rank)
7809 : {
7810 1 : gfc_error ("Element with a value of %d in ORDER at %L must be "
7811 : "in the range [1, ..., %d] for the RESHAPE intrinsic "
7812 : "near %L", order[i], &order_exp->where, rank,
7813 : &shape_exp->where);
7814 1 : mpz_clear (index);
7815 1 : return &gfc_bad_expr;
7816 : }
7817 :
7818 39 : order[i]--;
7819 39 : if (x[order[i]] != 0)
7820 : {
7821 1 : gfc_error ("ORDER at %L is not a permutation of the size of "
7822 : "SHAPE at %L", &order_exp->where, &shape_exp->where);
7823 1 : mpz_clear (index);
7824 1 : return &gfc_bad_expr;
7825 : }
7826 38 : x[order[i]] = 1;
7827 : }
7828 : }
7829 :
7830 : /* Count the elements in the source and padding arrays. */
7831 :
7832 6618 : npad = 0;
7833 6618 : if (pad != NULL)
7834 : {
7835 56 : gfc_array_size (pad, &size);
7836 56 : npad = mpz_get_ui (size);
7837 56 : mpz_clear (size);
7838 : }
7839 :
7840 6618 : gfc_array_size (source, &size);
7841 6618 : nsource = mpz_get_ui (size);
7842 6618 : mpz_clear (size);
7843 :
7844 : /* If it weren't for that pesky permutation we could just loop
7845 : through the source and round out any shortage with pad elements.
7846 : But no, someone just had to have the compiler do something the
7847 : user should be doing. */
7848 :
7849 28628 : for (i = 0; i < rank; i++)
7850 15392 : x[i] = 0;
7851 :
7852 6618 : result = gfc_get_array_expr (source->ts.type, source->ts.kind,
7853 : &source->where);
7854 6618 : if (source->ts.type == BT_DERIVED)
7855 116 : result->ts.u.derived = source->ts.u.derived;
7856 6618 : if (source->ts.type == BT_CHARACTER && result->ts.u.cl == NULL)
7857 278 : result->ts = source->ts;
7858 6618 : result->rank = rank;
7859 6618 : result->shape = gfc_get_shape (rank);
7860 22010 : for (i = 0; i < rank; i++)
7861 : {
7862 15392 : mpz_init_set_ui (result->shape[i], shape[i]);
7863 15392 : if (shape[i] == 0)
7864 723 : zerosize = true;
7865 : }
7866 :
7867 6618 : if (zerosize)
7868 699 : goto sizezero;
7869 :
7870 113766 : while (nsource > 0 || npad > 0)
7871 : {
7872 : /* Figure out which element to extract. */
7873 113766 : mpz_set_ui (index, 0);
7874 :
7875 401614 : for (i = rank - 1; i >= 0; i--)
7876 : {
7877 287848 : mpz_add_ui (index, index, x[order[i]]);
7878 287848 : if (i != 0)
7879 174082 : mpz_mul_ui (index, index, shape[order[i - 1]]);
7880 : }
7881 :
7882 113766 : if (mpz_cmp_ui (index, INT_MAX) > 0)
7883 0 : gfc_internal_error ("Reshaped array too large at %C");
7884 :
7885 113766 : j = mpz_get_ui (index);
7886 :
7887 113766 : if (j < nsource)
7888 113575 : e = gfc_constructor_lookup_expr (source->value.constructor, j);
7889 : else
7890 : {
7891 191 : if (npad <= 0)
7892 : {
7893 19 : mpz_clear (index);
7894 19 : if (pad == NULL)
7895 19 : gfc_error ("Without padding, there are not enough elements "
7896 : "in the intrinsic RESHAPE source at %L to match "
7897 : "the shape", &source->where);
7898 19 : gfc_free_expr (result);
7899 19 : return NULL;
7900 : }
7901 172 : j = j - nsource;
7902 172 : j = j % npad;
7903 172 : e = gfc_constructor_lookup_expr (pad->value.constructor, j);
7904 : }
7905 113747 : gcc_assert (e);
7906 :
7907 113747 : gfc_constructor_append_expr (&result->value.constructor,
7908 : gfc_copy_expr (e), &e->where);
7909 :
7910 : /* Calculate the next element. */
7911 113747 : i = 0;
7912 :
7913 150590 : inc:
7914 150590 : if (++x[i] < shape[i])
7915 107847 : continue;
7916 42743 : x[i++] = 0;
7917 42743 : if (i < rank)
7918 36843 : goto inc;
7919 :
7920 : break;
7921 : }
7922 :
7923 0 : sizezero:
7924 :
7925 6599 : mpz_clear (index);
7926 :
7927 6599 : return result;
7928 : }
7929 :
7930 :
7931 : gfc_expr *
7932 192 : gfc_simplify_rrspacing (gfc_expr *x)
7933 : {
7934 192 : gfc_expr *result;
7935 192 : int i;
7936 192 : long int e, p;
7937 :
7938 192 : if (x->expr_type != EXPR_CONSTANT)
7939 : return NULL;
7940 :
7941 60 : i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
7942 :
7943 60 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7944 :
7945 : /* RRSPACING(+/- 0.0) = 0.0 */
7946 60 : if (mpfr_zero_p (x->value.real))
7947 : {
7948 12 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
7949 12 : return result;
7950 : }
7951 :
7952 : /* RRSPACING(inf) = NaN */
7953 48 : if (mpfr_inf_p (x->value.real))
7954 : {
7955 12 : mpfr_set_nan (result->value.real);
7956 12 : return result;
7957 : }
7958 :
7959 : /* RRSPACING(NaN) = same NaN */
7960 36 : if (mpfr_nan_p (x->value.real))
7961 : {
7962 6 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7963 6 : return result;
7964 : }
7965 :
7966 : /* | x * 2**(-e) | * 2**p. */
7967 30 : mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
7968 30 : e = - (long int) mpfr_get_exp (x->value.real);
7969 30 : mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
7970 :
7971 30 : p = (long int) gfc_real_kinds[i].digits;
7972 30 : mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
7973 :
7974 30 : return range_check (result, "RRSPACING");
7975 : }
7976 :
7977 :
7978 : gfc_expr *
7979 168 : gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
7980 : {
7981 168 : int k, neg_flag, power, exp_range;
7982 168 : mpfr_t scale, radix;
7983 168 : gfc_expr *result;
7984 :
7985 168 : if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
7986 : return NULL;
7987 :
7988 12 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7989 :
7990 12 : if (mpfr_zero_p (x->value.real))
7991 : {
7992 0 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
7993 0 : return result;
7994 : }
7995 :
7996 12 : k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
7997 :
7998 12 : exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
7999 :
8000 : /* This check filters out values of i that would overflow an int. */
8001 12 : if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
8002 12 : || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
8003 : {
8004 0 : gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
8005 0 : gfc_free_expr (result);
8006 0 : return &gfc_bad_expr;
8007 : }
8008 :
8009 : /* Compute scale = radix ** power. */
8010 12 : power = mpz_get_si (i->value.integer);
8011 :
8012 12 : if (power >= 0)
8013 : neg_flag = 0;
8014 : else
8015 : {
8016 0 : neg_flag = 1;
8017 0 : power = -power;
8018 : }
8019 :
8020 12 : gfc_set_model_kind (x->ts.kind);
8021 12 : mpfr_init (scale);
8022 12 : mpfr_init (radix);
8023 12 : mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
8024 12 : mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
8025 :
8026 12 : if (neg_flag)
8027 0 : mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
8028 : else
8029 12 : mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
8030 :
8031 12 : mpfr_clears (scale, radix, NULL);
8032 :
8033 12 : return range_check (result, "SCALE");
8034 : }
8035 :
8036 :
8037 : /* Variants of strspn and strcspn that operate on wide characters. */
8038 :
8039 : static size_t
8040 60 : wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
8041 : {
8042 60 : size_t i = 0;
8043 60 : const gfc_char_t *c;
8044 :
8045 144 : while (s1[i])
8046 : {
8047 354 : for (c = s2; *c; c++)
8048 : {
8049 294 : if (s1[i] == *c)
8050 : break;
8051 : }
8052 144 : if (*c == '\0')
8053 : break;
8054 84 : i++;
8055 : }
8056 :
8057 60 : return i;
8058 : }
8059 :
8060 : static size_t
8061 60 : wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
8062 : {
8063 60 : size_t i = 0;
8064 60 : const gfc_char_t *c;
8065 :
8066 396 : while (s1[i])
8067 : {
8068 1392 : for (c = s2; *c; c++)
8069 : {
8070 1056 : if (s1[i] == *c)
8071 : break;
8072 : }
8073 384 : if (*c)
8074 : break;
8075 336 : i++;
8076 : }
8077 :
8078 60 : return i;
8079 : }
8080 :
8081 :
8082 : gfc_expr *
8083 958 : gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
8084 : {
8085 958 : gfc_expr *result;
8086 958 : int back;
8087 958 : size_t i;
8088 958 : size_t indx, len, lenc;
8089 958 : int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
8090 :
8091 958 : if (k == -1)
8092 : return &gfc_bad_expr;
8093 :
8094 958 : if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
8095 182 : || ( b != NULL && b->expr_type != EXPR_CONSTANT))
8096 : return NULL;
8097 :
8098 144 : if (b != NULL && b->value.logical != 0)
8099 : back = 1;
8100 : else
8101 72 : back = 0;
8102 :
8103 144 : len = e->value.character.length;
8104 144 : lenc = c->value.character.length;
8105 :
8106 144 : if (len == 0 || lenc == 0)
8107 : {
8108 : indx = 0;
8109 : }
8110 : else
8111 : {
8112 120 : if (back == 0)
8113 : {
8114 60 : indx = wide_strcspn (e->value.character.string,
8115 60 : c->value.character.string) + 1;
8116 60 : if (indx > len)
8117 48 : indx = 0;
8118 : }
8119 : else
8120 408 : for (indx = len; indx > 0; indx--)
8121 : {
8122 1488 : for (i = 0; i < lenc; i++)
8123 : {
8124 1140 : if (c->value.character.string[i]
8125 1140 : == e->value.character.string[indx - 1])
8126 : break;
8127 : }
8128 396 : if (i < lenc)
8129 : break;
8130 : }
8131 : }
8132 :
8133 144 : result = gfc_get_int_expr (k, &e->where, indx);
8134 144 : return range_check (result, "SCAN");
8135 : }
8136 :
8137 :
8138 : gfc_expr *
8139 265 : gfc_simplify_selected_char_kind (gfc_expr *e)
8140 : {
8141 265 : int kind;
8142 :
8143 265 : if (e->expr_type != EXPR_CONSTANT)
8144 : return NULL;
8145 :
8146 180 : if (gfc_compare_with_Cstring (e, "ascii", false) == 0
8147 180 : || gfc_compare_with_Cstring (e, "default", false) == 0)
8148 : kind = 1;
8149 96 : else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
8150 : kind = 4;
8151 : else
8152 39 : kind = -1;
8153 :
8154 180 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
8155 : }
8156 :
8157 :
8158 : gfc_expr *
8159 261 : gfc_simplify_selected_int_kind (gfc_expr *e)
8160 : {
8161 261 : int i, kind, range;
8162 :
8163 261 : if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
8164 49 : return NULL;
8165 :
8166 : kind = INT_MAX;
8167 :
8168 1272 : for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
8169 1060 : if (gfc_integer_kinds[i].range >= range
8170 544 : && gfc_integer_kinds[i].kind < kind)
8171 1060 : kind = gfc_integer_kinds[i].kind;
8172 :
8173 212 : if (kind == INT_MAX)
8174 0 : kind = -1;
8175 :
8176 212 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
8177 : }
8178 :
8179 : /* Same as above, but with unsigneds. */
8180 :
8181 : gfc_expr *
8182 25 : gfc_simplify_selected_unsigned_kind (gfc_expr *e)
8183 : {
8184 25 : int i, kind, range;
8185 :
8186 25 : if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
8187 0 : return NULL;
8188 :
8189 : kind = INT_MAX;
8190 :
8191 150 : for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
8192 125 : if (gfc_unsigned_kinds[i].range >= range
8193 86 : && gfc_unsigned_kinds[i].kind < kind)
8194 125 : kind = gfc_unsigned_kinds[i].kind;
8195 :
8196 25 : if (kind == INT_MAX)
8197 0 : kind = -1;
8198 :
8199 25 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
8200 : }
8201 :
8202 :
8203 : gfc_expr *
8204 78 : gfc_simplify_selected_logical_kind (gfc_expr *e)
8205 : {
8206 78 : int i, kind, bits;
8207 :
8208 78 : if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &bits))
8209 12 : return NULL;
8210 :
8211 : kind = INT_MAX;
8212 :
8213 396 : for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
8214 330 : if (gfc_logical_kinds[i].bit_size >= bits
8215 180 : && gfc_logical_kinds[i].kind < kind)
8216 330 : kind = gfc_logical_kinds[i].kind;
8217 :
8218 66 : if (kind == INT_MAX)
8219 6 : kind = -1;
8220 :
8221 66 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
8222 : }
8223 :
8224 :
8225 : gfc_expr *
8226 991 : gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
8227 : {
8228 991 : int range, precision, radix, i, kind, found_precision, found_range,
8229 : found_radix;
8230 991 : locus *loc = &gfc_current_locus;
8231 :
8232 991 : if (p == NULL)
8233 60 : precision = 0;
8234 : else
8235 : {
8236 931 : if (p->expr_type != EXPR_CONSTANT
8237 931 : || gfc_extract_int (p, &precision))
8238 46 : return NULL;
8239 885 : loc = &p->where;
8240 : }
8241 :
8242 945 : if (q == NULL)
8243 682 : range = 0;
8244 : else
8245 : {
8246 263 : if (q->expr_type != EXPR_CONSTANT
8247 263 : || gfc_extract_int (q, &range))
8248 54 : return NULL;
8249 :
8250 : if (!loc)
8251 : loc = &q->where;
8252 : }
8253 :
8254 891 : if (rdx == NULL)
8255 831 : radix = 0;
8256 : else
8257 : {
8258 60 : if (rdx->expr_type != EXPR_CONSTANT
8259 60 : || gfc_extract_int (rdx, &radix))
8260 24 : return NULL;
8261 :
8262 : if (!loc)
8263 : loc = &rdx->where;
8264 : }
8265 :
8266 867 : kind = INT_MAX;
8267 867 : found_precision = 0;
8268 867 : found_range = 0;
8269 867 : found_radix = 0;
8270 :
8271 4335 : for (i = 0; gfc_real_kinds[i].kind != 0; i++)
8272 : {
8273 3468 : if (gfc_real_kinds[i].precision >= precision)
8274 2342 : found_precision = 1;
8275 :
8276 3468 : if (gfc_real_kinds[i].range >= range)
8277 3349 : found_range = 1;
8278 :
8279 3468 : if (radix == 0 || gfc_real_kinds[i].radix == radix)
8280 3444 : found_radix = 1;
8281 :
8282 3468 : if (gfc_real_kinds[i].precision >= precision
8283 2342 : && gfc_real_kinds[i].range >= range
8284 2342 : && (radix == 0 || gfc_real_kinds[i].radix == radix)
8285 2318 : && gfc_real_kinds[i].kind < kind)
8286 3468 : kind = gfc_real_kinds[i].kind;
8287 : }
8288 :
8289 867 : if (kind == INT_MAX)
8290 : {
8291 12 : if (found_radix && found_range && !found_precision)
8292 : kind = -1;
8293 6 : else if (found_radix && found_precision && !found_range)
8294 : kind = -2;
8295 6 : else if (found_radix && !found_precision && !found_range)
8296 : kind = -3;
8297 6 : else if (found_radix)
8298 : kind = -4;
8299 : else
8300 6 : kind = -5;
8301 : }
8302 :
8303 867 : return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
8304 : }
8305 :
8306 :
8307 : gfc_expr *
8308 770 : gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
8309 : {
8310 770 : gfc_expr *result;
8311 770 : mpfr_t exp, absv, log2, pow2, frac;
8312 770 : long exp2;
8313 :
8314 770 : if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
8315 : return NULL;
8316 :
8317 150 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
8318 :
8319 : /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
8320 : SET_EXPONENT (NaN) = same NaN */
8321 150 : if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real))
8322 : {
8323 18 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
8324 18 : return result;
8325 : }
8326 :
8327 : /* SET_EXPONENT (inf) = NaN */
8328 132 : if (mpfr_inf_p (x->value.real))
8329 : {
8330 12 : mpfr_set_nan (result->value.real);
8331 12 : return result;
8332 : }
8333 :
8334 120 : gfc_set_model_kind (x->ts.kind);
8335 120 : mpfr_init (absv);
8336 120 : mpfr_init (log2);
8337 120 : mpfr_init (exp);
8338 120 : mpfr_init (pow2);
8339 120 : mpfr_init (frac);
8340 :
8341 120 : mpfr_abs (absv, x->value.real, GFC_RND_MODE);
8342 120 : mpfr_log2 (log2, absv, GFC_RND_MODE);
8343 :
8344 120 : mpfr_floor (log2, log2);
8345 120 : mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
8346 :
8347 : /* Old exponent value, and fraction. */
8348 120 : mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
8349 :
8350 120 : mpfr_div (frac, x->value.real, pow2, GFC_RND_MODE);
8351 :
8352 : /* New exponent. */
8353 120 : exp2 = mpz_get_si (i->value.integer);
8354 120 : mpfr_mul_2si (result->value.real, frac, exp2, GFC_RND_MODE);
8355 :
8356 120 : mpfr_clears (absv, log2, exp, pow2, frac, NULL);
8357 :
8358 120 : return range_check (result, "SET_EXPONENT");
8359 : }
8360 :
8361 :
8362 : gfc_expr *
8363 11965 : gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
8364 : {
8365 11965 : mpz_t shape[GFC_MAX_DIMENSIONS];
8366 11965 : gfc_expr *result, *e, *f;
8367 11965 : gfc_array_ref *ar;
8368 11965 : int n;
8369 11965 : bool t;
8370 11965 : int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
8371 :
8372 11965 : if (source->rank == -1)
8373 : return NULL;
8374 :
8375 11053 : result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
8376 11053 : result->shape = gfc_get_shape (1);
8377 11053 : mpz_init (result->shape[0]);
8378 :
8379 11053 : if (source->rank == 0)
8380 : return result;
8381 :
8382 11002 : if (source->expr_type == EXPR_VARIABLE)
8383 : {
8384 10958 : ar = gfc_find_array_ref (source);
8385 10958 : t = gfc_array_ref_shape (ar, shape);
8386 : }
8387 44 : else if (source->shape)
8388 : {
8389 37 : t = true;
8390 37 : for (n = 0; n < source->rank; n++)
8391 : {
8392 24 : mpz_init (shape[n]);
8393 24 : mpz_set (shape[n], source->shape[n]);
8394 : }
8395 : }
8396 : else
8397 : t = false;
8398 :
8399 17592 : for (n = 0; n < source->rank; n++)
8400 : {
8401 15248 : e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
8402 :
8403 15248 : if (t)
8404 6576 : mpz_set (e->value.integer, shape[n]);
8405 : else
8406 : {
8407 8672 : mpz_set_ui (e->value.integer, n + 1);
8408 :
8409 8672 : f = simplify_size (source, e, k);
8410 8672 : gfc_free_expr (e);
8411 8672 : if (f == NULL)
8412 : {
8413 8657 : gfc_free_expr (result);
8414 8657 : return NULL;
8415 : }
8416 : else
8417 : e = f;
8418 : }
8419 :
8420 6591 : if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
8421 : {
8422 1 : gfc_free_expr (result);
8423 1 : if (t)
8424 1 : gfc_clear_shape (shape, source->rank);
8425 1 : return &gfc_bad_expr;
8426 : }
8427 :
8428 6590 : gfc_constructor_append_expr (&result->value.constructor, e, NULL);
8429 : }
8430 :
8431 2344 : if (t)
8432 2344 : gfc_clear_shape (shape, source->rank);
8433 :
8434 2344 : mpz_set_si (result->shape[0], source->rank);
8435 :
8436 2344 : return result;
8437 : }
8438 :
8439 :
8440 : static gfc_expr *
8441 41496 : simplify_size (gfc_expr *array, gfc_expr *dim, int k)
8442 : {
8443 41496 : mpz_t size;
8444 41496 : gfc_expr *return_value;
8445 41496 : int d;
8446 41496 : gfc_ref *ref;
8447 :
8448 : /* For unary operations, the size of the result is given by the size
8449 : of the operand. For binary ones, it's the size of the first operand
8450 : unless it is scalar, then it is the size of the second. */
8451 41496 : if (array->expr_type == EXPR_OP && !array->value.op.uop)
8452 : {
8453 44 : gfc_expr* replacement;
8454 44 : gfc_expr* simplified;
8455 :
8456 44 : switch (array->value.op.op)
8457 : {
8458 : /* Unary operations. */
8459 7 : case INTRINSIC_NOT:
8460 7 : case INTRINSIC_UPLUS:
8461 7 : case INTRINSIC_UMINUS:
8462 7 : case INTRINSIC_PARENTHESES:
8463 7 : replacement = array->value.op.op1;
8464 7 : break;
8465 :
8466 : /* Binary operations. If any one of the operands is scalar, take
8467 : the other one's size. If both of them are arrays, it does not
8468 : matter -- try to find one with known shape, if possible. */
8469 37 : default:
8470 37 : if (array->value.op.op1->rank == 0)
8471 25 : replacement = array->value.op.op2;
8472 12 : else if (array->value.op.op2->rank == 0)
8473 : replacement = array->value.op.op1;
8474 : else
8475 : {
8476 0 : simplified = simplify_size (array->value.op.op1, dim, k);
8477 0 : if (simplified)
8478 : return simplified;
8479 :
8480 0 : replacement = array->value.op.op2;
8481 : }
8482 : break;
8483 : }
8484 :
8485 : /* Try to reduce it directly if possible. */
8486 44 : simplified = simplify_size (replacement, dim, k);
8487 :
8488 : /* Otherwise, we build a new SIZE call. This is hopefully at least
8489 : simpler than the original one. */
8490 44 : if (!simplified)
8491 : {
8492 20 : gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
8493 20 : simplified = gfc_build_intrinsic_call (gfc_current_ns,
8494 : GFC_ISYM_SIZE, "size",
8495 : array->where, 3,
8496 : gfc_copy_expr (replacement),
8497 : gfc_copy_expr (dim),
8498 : kind);
8499 : }
8500 44 : return simplified;
8501 : }
8502 :
8503 84046 : for (ref = array->ref; ref; ref = ref->next)
8504 39643 : if (ref->type == REF_ARRAY && ref->u.ar.as
8505 82241 : && !gfc_resolve_array_spec (ref->u.ar.as, 0))
8506 : return NULL;
8507 :
8508 41448 : if (dim == NULL)
8509 : {
8510 15975 : if (!gfc_array_size (array, &size))
8511 : return NULL;
8512 : }
8513 : else
8514 : {
8515 25473 : if (dim->expr_type != EXPR_CONSTANT)
8516 : return NULL;
8517 :
8518 25139 : if (array->rank == -1)
8519 : return NULL;
8520 :
8521 24497 : d = mpz_get_si (dim->value.integer) - 1;
8522 24497 : if (d < 0 || d > array->rank - 1)
8523 : {
8524 6 : gfc_error ("DIM argument (%d) to intrinsic SIZE at %L out of range "
8525 : "(1:%d)", d+1, &array->where, array->rank);
8526 6 : return &gfc_bad_expr;
8527 : }
8528 :
8529 24491 : if (!gfc_array_dimen_size (array, d, &size))
8530 : return NULL;
8531 : }
8532 :
8533 4912 : return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
8534 4912 : mpz_set (return_value->value.integer, size);
8535 4912 : mpz_clear (size);
8536 :
8537 4912 : return return_value;
8538 : }
8539 :
8540 :
8541 : gfc_expr *
8542 31998 : gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
8543 : {
8544 31998 : gfc_expr *result;
8545 31998 : int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
8546 :
8547 31998 : if (k == -1)
8548 : return &gfc_bad_expr;
8549 :
8550 31998 : result = simplify_size (array, dim, k);
8551 31998 : if (result == NULL || result == &gfc_bad_expr)
8552 : return result;
8553 :
8554 4510 : return range_check (result, "SIZE");
8555 : }
8556 :
8557 :
8558 : /* SIZEOF and C_SIZEOF return the size in bytes of an array element
8559 : multiplied by the array size. */
8560 :
8561 : gfc_expr *
8562 3425 : gfc_simplify_sizeof (gfc_expr *x)
8563 : {
8564 3425 : gfc_expr *result = NULL;
8565 3425 : mpz_t array_size;
8566 3425 : size_t res_size;
8567 :
8568 3425 : if (x->ts.type == BT_CLASS || x->ts.deferred)
8569 : return NULL;
8570 :
8571 2342 : if (x->ts.type == BT_CHARACTER
8572 249 : && (!x->ts.u.cl || !x->ts.u.cl->length
8573 75 : || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
8574 : return NULL;
8575 :
8576 2150 : if (x->rank && x->expr_type != EXPR_ARRAY)
8577 : {
8578 1388 : if (!gfc_array_size (x, &array_size))
8579 : return NULL;
8580 :
8581 168 : mpz_clear (array_size);
8582 : }
8583 :
8584 930 : result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
8585 : &x->where);
8586 930 : gfc_target_expr_size (x, &res_size);
8587 930 : mpz_set_si (result->value.integer, res_size);
8588 :
8589 930 : return result;
8590 : }
8591 :
8592 :
8593 : /* STORAGE_SIZE returns the size in bits of a single array element. */
8594 :
8595 : gfc_expr *
8596 1386 : gfc_simplify_storage_size (gfc_expr *x,
8597 : gfc_expr *kind)
8598 : {
8599 1386 : gfc_expr *result = NULL;
8600 1386 : int k;
8601 1386 : size_t siz;
8602 :
8603 1386 : if (x->ts.type == BT_CLASS || x->ts.deferred)
8604 : return NULL;
8605 :
8606 839 : if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
8607 297 : && (!x->ts.u.cl || !x->ts.u.cl->length
8608 96 : || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
8609 : return NULL;
8610 :
8611 638 : k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
8612 638 : if (k == -1)
8613 : return &gfc_bad_expr;
8614 :
8615 638 : result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
8616 :
8617 638 : gfc_element_size (x, &siz);
8618 638 : mpz_set_si (result->value.integer, siz);
8619 638 : mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
8620 :
8621 638 : return range_check (result, "STORAGE_SIZE");
8622 : }
8623 :
8624 :
8625 : gfc_expr *
8626 1365 : gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
8627 : {
8628 1365 : gfc_expr *result;
8629 :
8630 1365 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
8631 : return NULL;
8632 :
8633 95 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8634 :
8635 95 : switch (x->ts.type)
8636 : {
8637 22 : case BT_INTEGER:
8638 22 : mpz_abs (result->value.integer, x->value.integer);
8639 22 : if (mpz_sgn (y->value.integer) < 0)
8640 0 : mpz_neg (result->value.integer, result->value.integer);
8641 : break;
8642 :
8643 73 : case BT_REAL:
8644 73 : if (flag_sign_zero)
8645 61 : mpfr_copysign (result->value.real, x->value.real, y->value.real,
8646 : GFC_RND_MODE);
8647 : else
8648 24 : mpfr_setsign (result->value.real, x->value.real,
8649 : mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
8650 : break;
8651 :
8652 0 : default:
8653 0 : gfc_internal_error ("Bad type in gfc_simplify_sign");
8654 : }
8655 :
8656 : return result;
8657 : }
8658 :
8659 :
8660 : gfc_expr *
8661 801 : gfc_simplify_sin (gfc_expr *x)
8662 : {
8663 801 : gfc_expr *result;
8664 :
8665 801 : if (x->expr_type != EXPR_CONSTANT)
8666 : return NULL;
8667 :
8668 163 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8669 :
8670 163 : switch (x->ts.type)
8671 : {
8672 106 : case BT_REAL:
8673 106 : mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
8674 106 : break;
8675 :
8676 57 : case BT_COMPLEX:
8677 57 : gfc_set_model (x->value.real);
8678 57 : mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
8679 57 : break;
8680 :
8681 0 : default:
8682 0 : gfc_internal_error ("in gfc_simplify_sin(): Bad type");
8683 : }
8684 :
8685 163 : return range_check (result, "SIN");
8686 : }
8687 :
8688 :
8689 : gfc_expr *
8690 316 : gfc_simplify_sinh (gfc_expr *x)
8691 : {
8692 316 : gfc_expr *result;
8693 :
8694 316 : if (x->expr_type != EXPR_CONSTANT)
8695 : return NULL;
8696 :
8697 46 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8698 :
8699 46 : switch (x->ts.type)
8700 : {
8701 42 : case BT_REAL:
8702 42 : mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
8703 42 : break;
8704 :
8705 4 : case BT_COMPLEX:
8706 4 : mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
8707 4 : break;
8708 :
8709 0 : default:
8710 0 : gcc_unreachable ();
8711 : }
8712 :
8713 46 : return range_check (result, "SINH");
8714 : }
8715 :
8716 :
8717 : /* The argument is always a double precision real that is converted to
8718 : single precision. TODO: Rounding! */
8719 :
8720 : gfc_expr *
8721 3 : gfc_simplify_sngl (gfc_expr *a)
8722 : {
8723 3 : gfc_expr *result;
8724 3 : int tmp1, tmp2;
8725 :
8726 3 : if (a->expr_type != EXPR_CONSTANT)
8727 : return NULL;
8728 :
8729 : /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
8730 : warnings. */
8731 3 : tmp1 = warn_conversion;
8732 3 : tmp2 = warn_conversion_extra;
8733 3 : warn_conversion = warn_conversion_extra = 0;
8734 :
8735 3 : result = gfc_real2real (a, gfc_default_real_kind);
8736 :
8737 3 : warn_conversion = tmp1;
8738 3 : warn_conversion_extra = tmp2;
8739 :
8740 3 : return range_check (result, "SNGL");
8741 : }
8742 :
8743 :
8744 : gfc_expr *
8745 309 : gfc_simplify_spacing (gfc_expr *x)
8746 : {
8747 309 : gfc_expr *result;
8748 309 : int i;
8749 309 : long int en, ep;
8750 :
8751 309 : if (x->expr_type != EXPR_CONSTANT)
8752 : return NULL;
8753 :
8754 96 : i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
8755 96 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
8756 :
8757 : /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
8758 96 : if (mpfr_zero_p (x->value.real))
8759 : {
8760 12 : mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
8761 12 : return result;
8762 : }
8763 :
8764 : /* SPACING(inf) = NaN */
8765 84 : if (mpfr_inf_p (x->value.real))
8766 : {
8767 12 : mpfr_set_nan (result->value.real);
8768 12 : return result;
8769 : }
8770 :
8771 : /* SPACING(NaN) = same NaN */
8772 72 : if (mpfr_nan_p (x->value.real))
8773 : {
8774 6 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
8775 6 : return result;
8776 : }
8777 :
8778 : /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
8779 : are the radix, exponent of x, and precision. This excludes the
8780 : possibility of subnormal numbers. Fortran 2003 states the result is
8781 : b**max(e - p, emin - 1). */
8782 :
8783 66 : ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
8784 66 : en = (long int) gfc_real_kinds[i].min_exponent - 1;
8785 66 : en = en > ep ? en : ep;
8786 :
8787 66 : mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
8788 66 : mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
8789 :
8790 66 : return range_check (result, "SPACING");
8791 : }
8792 :
8793 :
8794 : gfc_expr *
8795 840 : gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
8796 : {
8797 840 : gfc_expr *result = NULL;
8798 840 : int nelem, i, j, dim, ncopies;
8799 840 : mpz_t size;
8800 :
8801 840 : if ((!gfc_is_constant_expr (source)
8802 727 : && !is_constant_array_expr (source))
8803 132 : || !gfc_is_constant_expr (dim_expr)
8804 972 : || !gfc_is_constant_expr (ncopies_expr))
8805 708 : return NULL;
8806 :
8807 132 : gcc_assert (dim_expr->ts.type == BT_INTEGER);
8808 132 : gfc_extract_int (dim_expr, &dim);
8809 132 : dim -= 1; /* zero-base DIM */
8810 :
8811 132 : gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
8812 132 : gfc_extract_int (ncopies_expr, &ncopies);
8813 132 : ncopies = MAX (ncopies, 0);
8814 :
8815 : /* Do not allow the array size to exceed the limit for an array
8816 : constructor. */
8817 132 : if (source->expr_type == EXPR_ARRAY)
8818 : {
8819 37 : if (!gfc_array_size (source, &size))
8820 0 : gfc_internal_error ("Failure getting length of a constant array.");
8821 : }
8822 : else
8823 95 : mpz_init_set_ui (size, 1);
8824 :
8825 132 : nelem = mpz_get_si (size) * ncopies;
8826 132 : if (nelem > flag_max_array_constructor)
8827 : {
8828 3 : if (gfc_init_expr_flag)
8829 : {
8830 2 : gfc_error ("The number of elements (%d) in the array constructor "
8831 : "at %L requires an increase of the allowed %d upper "
8832 : "limit. See %<-fmax-array-constructor%> option.",
8833 : nelem, &source->where, flag_max_array_constructor);
8834 2 : return &gfc_bad_expr;
8835 : }
8836 : else
8837 : return NULL;
8838 : }
8839 :
8840 129 : if (source->expr_type == EXPR_CONSTANT
8841 40 : || source->expr_type == EXPR_STRUCTURE)
8842 : {
8843 95 : gcc_assert (dim == 0);
8844 :
8845 95 : result = gfc_get_array_expr (source->ts.type, source->ts.kind,
8846 : &source->where);
8847 95 : if (source->ts.type == BT_DERIVED)
8848 6 : result->ts.u.derived = source->ts.u.derived;
8849 95 : result->rank = 1;
8850 95 : result->shape = gfc_get_shape (result->rank);
8851 95 : mpz_init_set_si (result->shape[0], ncopies);
8852 :
8853 919 : for (i = 0; i < ncopies; ++i)
8854 729 : gfc_constructor_append_expr (&result->value.constructor,
8855 : gfc_copy_expr (source), NULL);
8856 : }
8857 34 : else if (source->expr_type == EXPR_ARRAY)
8858 : {
8859 34 : int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
8860 34 : gfc_constructor *source_ctor;
8861 :
8862 34 : gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
8863 34 : gcc_assert (dim >= 0 && dim <= source->rank);
8864 :
8865 34 : result = gfc_get_array_expr (source->ts.type, source->ts.kind,
8866 : &source->where);
8867 34 : if (source->ts.type == BT_DERIVED)
8868 1 : result->ts.u.derived = source->ts.u.derived;
8869 34 : result->rank = source->rank + 1;
8870 34 : result->shape = gfc_get_shape (result->rank);
8871 :
8872 120 : for (i = 0, j = 0; i < result->rank; ++i)
8873 : {
8874 86 : if (i != dim)
8875 52 : mpz_init_set (result->shape[i], source->shape[j++]);
8876 : else
8877 34 : mpz_init_set_si (result->shape[i], ncopies);
8878 :
8879 86 : extent[i] = mpz_get_si (result->shape[i]);
8880 86 : rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
8881 : }
8882 :
8883 34 : offset = 0;
8884 34 : for (source_ctor = gfc_constructor_first (source->value.constructor);
8885 242 : source_ctor; source_ctor = gfc_constructor_next (source_ctor))
8886 : {
8887 732 : for (i = 0; i < ncopies; ++i)
8888 524 : gfc_constructor_insert_expr (&result->value.constructor,
8889 : gfc_copy_expr (source_ctor->expr),
8890 524 : NULL, offset + i * rstride[dim]);
8891 :
8892 390 : offset += (dim == 0 ? ncopies : 1);
8893 : }
8894 : }
8895 : else
8896 : {
8897 0 : gfc_error ("Simplification of SPREAD at %C not yet implemented");
8898 0 : return &gfc_bad_expr;
8899 : }
8900 :
8901 129 : if (source->ts.type == BT_CHARACTER)
8902 20 : result->ts.u.cl = source->ts.u.cl;
8903 :
8904 : return result;
8905 : }
8906 :
8907 :
8908 : gfc_expr *
8909 1359 : gfc_simplify_sqrt (gfc_expr *e)
8910 : {
8911 1359 : gfc_expr *result = NULL;
8912 :
8913 1359 : if (e->expr_type != EXPR_CONSTANT)
8914 : return NULL;
8915 :
8916 221 : switch (e->ts.type)
8917 : {
8918 164 : case BT_REAL:
8919 164 : if (mpfr_cmp_si (e->value.real, 0) < 0)
8920 : {
8921 0 : gfc_error ("Argument of SQRT at %L has a negative value",
8922 : &e->where);
8923 0 : return &gfc_bad_expr;
8924 : }
8925 164 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
8926 164 : mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
8927 164 : break;
8928 :
8929 57 : case BT_COMPLEX:
8930 57 : gfc_set_model (e->value.real);
8931 :
8932 57 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
8933 57 : mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
8934 57 : break;
8935 :
8936 0 : default:
8937 0 : gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
8938 : }
8939 :
8940 221 : return range_check (result, "SQRT");
8941 : }
8942 :
8943 :
8944 : gfc_expr *
8945 4670 : gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
8946 : {
8947 4670 : return simplify_transformation (array, dim, mask, 0, gfc_add);
8948 : }
8949 :
8950 :
8951 : /* Simplify COTAN(X) where X has the unit of radian. */
8952 :
8953 : gfc_expr *
8954 230 : gfc_simplify_cotan (gfc_expr *x)
8955 : {
8956 230 : gfc_expr *result;
8957 230 : mpc_t swp, *val;
8958 :
8959 230 : if (x->expr_type != EXPR_CONSTANT)
8960 : return NULL;
8961 :
8962 26 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8963 :
8964 26 : switch (x->ts.type)
8965 : {
8966 25 : case BT_REAL:
8967 25 : mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE);
8968 25 : break;
8969 :
8970 1 : case BT_COMPLEX:
8971 : /* There is no builtin mpc_cot, so compute cot = cos / sin. */
8972 1 : val = &result->value.complex;
8973 1 : mpc_init2 (swp, mpfr_get_default_prec ());
8974 1 : mpc_sin_cos (*val, swp, x->value.complex, GFC_MPC_RND_MODE,
8975 : GFC_MPC_RND_MODE);
8976 1 : mpc_div (*val, swp, *val, GFC_MPC_RND_MODE);
8977 1 : mpc_clear (swp);
8978 1 : break;
8979 :
8980 0 : default:
8981 0 : gcc_unreachable ();
8982 : }
8983 :
8984 26 : return range_check (result, "COTAN");
8985 : }
8986 :
8987 :
8988 : gfc_expr *
8989 586 : gfc_simplify_tan (gfc_expr *x)
8990 : {
8991 586 : gfc_expr *result;
8992 :
8993 586 : if (x->expr_type != EXPR_CONSTANT)
8994 : return NULL;
8995 :
8996 46 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8997 :
8998 46 : switch (x->ts.type)
8999 : {
9000 42 : case BT_REAL:
9001 42 : mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
9002 42 : break;
9003 :
9004 4 : case BT_COMPLEX:
9005 4 : mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
9006 4 : break;
9007 :
9008 0 : default:
9009 0 : gcc_unreachable ();
9010 : }
9011 :
9012 46 : return range_check (result, "TAN");
9013 : }
9014 :
9015 :
9016 : gfc_expr *
9017 316 : gfc_simplify_tanh (gfc_expr *x)
9018 : {
9019 316 : gfc_expr *result;
9020 :
9021 316 : if (x->expr_type != EXPR_CONSTANT)
9022 : return NULL;
9023 :
9024 46 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
9025 :
9026 46 : switch (x->ts.type)
9027 : {
9028 42 : case BT_REAL:
9029 42 : mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
9030 42 : break;
9031 :
9032 4 : case BT_COMPLEX:
9033 4 : mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
9034 4 : break;
9035 :
9036 0 : default:
9037 0 : gcc_unreachable ();
9038 : }
9039 :
9040 46 : return range_check (result, "TANH");
9041 : }
9042 :
9043 :
9044 : gfc_expr *
9045 804 : gfc_simplify_tiny (gfc_expr *e)
9046 : {
9047 804 : gfc_expr *result;
9048 804 : int i;
9049 :
9050 804 : i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
9051 :
9052 804 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
9053 804 : mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
9054 :
9055 804 : return result;
9056 : }
9057 :
9058 :
9059 : gfc_expr *
9060 1104 : gfc_simplify_trailz (gfc_expr *e)
9061 : {
9062 1104 : unsigned long tz, bs;
9063 1104 : int i;
9064 :
9065 1104 : if (e->expr_type != EXPR_CONSTANT)
9066 : return NULL;
9067 :
9068 258 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
9069 258 : bs = gfc_integer_kinds[i].bit_size;
9070 258 : tz = mpz_scan1 (e->value.integer, 0);
9071 :
9072 258 : return gfc_get_int_expr (gfc_default_integer_kind,
9073 258 : &e->where, MIN (tz, bs));
9074 : }
9075 :
9076 :
9077 : gfc_expr *
9078 2870 : gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
9079 : {
9080 2870 : gfc_expr *result;
9081 2870 : gfc_expr *mold_element;
9082 2870 : size_t source_size;
9083 2870 : size_t result_size;
9084 2870 : size_t buffer_size;
9085 2870 : mpz_t tmp;
9086 2870 : unsigned char *buffer;
9087 2870 : size_t result_length;
9088 :
9089 2870 : if (!gfc_is_constant_expr (source) || !gfc_is_constant_expr (size))
9090 1931 : return NULL;
9091 :
9092 939 : if (!gfc_resolve_expr (mold))
9093 : return NULL;
9094 939 : if (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
9095 : return NULL;
9096 :
9097 893 : if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
9098 : &result_size, &result_length))
9099 : return NULL;
9100 :
9101 : /* Calculate the size of the source. */
9102 859 : if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp))
9103 0 : gfc_internal_error ("Failure getting length of a constant array.");
9104 :
9105 : /* Create an empty new expression with the appropriate characteristics. */
9106 859 : result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
9107 : &source->where);
9108 859 : result->ts = mold->ts;
9109 :
9110 336 : mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor)
9111 1018 : ? gfc_constructor_first (mold->value.constructor)->expr
9112 : : mold;
9113 :
9114 : /* Set result character length, if needed. Note that this needs to be
9115 : set even for array expressions, in order to pass this information into
9116 : gfc_target_interpret_expr. */
9117 859 : if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
9118 : {
9119 341 : result->value.character.length = mold_element->value.character.length;
9120 :
9121 : /* Let the typespec of the result inherit the string length.
9122 : This is crucial if a resulting array has size zero. */
9123 341 : if (mold_element->ts.u.cl->length)
9124 230 : result->ts.u.cl->length = gfc_copy_expr (mold_element->ts.u.cl->length);
9125 : else
9126 111 : result->ts.u.cl->length =
9127 111 : gfc_get_int_expr (gfc_charlen_int_kind, NULL,
9128 : mold_element->value.character.length);
9129 : }
9130 :
9131 : /* Set the number of elements in the result, and determine its size. */
9132 :
9133 859 : if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
9134 : {
9135 273 : result->expr_type = EXPR_ARRAY;
9136 273 : result->rank = 1;
9137 273 : result->shape = gfc_get_shape (1);
9138 273 : mpz_init_set_ui (result->shape[0], result_length);
9139 : }
9140 : else
9141 586 : result->rank = 0;
9142 :
9143 : /* Allocate the buffer to store the binary version of the source. */
9144 859 : buffer_size = MAX (source_size, result_size);
9145 859 : buffer = (unsigned char*)alloca (buffer_size);
9146 859 : memset (buffer, 0, buffer_size);
9147 :
9148 : /* Now write source to the buffer. */
9149 859 : gfc_target_encode_expr (source, buffer, buffer_size);
9150 :
9151 : /* And read the buffer back into the new expression. */
9152 859 : gfc_target_interpret_expr (buffer, buffer_size, result, false);
9153 :
9154 859 : return result;
9155 : }
9156 :
9157 :
9158 : gfc_expr *
9159 1625 : gfc_simplify_transpose (gfc_expr *matrix)
9160 : {
9161 1625 : int row, matrix_rows, col, matrix_cols;
9162 1625 : gfc_expr *result;
9163 :
9164 1625 : if (!is_constant_array_expr (matrix))
9165 : return NULL;
9166 :
9167 45 : gcc_assert (matrix->rank == 2);
9168 :
9169 45 : if (matrix->shape == NULL)
9170 : return NULL;
9171 :
9172 45 : result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
9173 : &matrix->where);
9174 45 : result->rank = 2;
9175 45 : result->shape = gfc_get_shape (result->rank);
9176 45 : mpz_init_set (result->shape[0], matrix->shape[1]);
9177 45 : mpz_init_set (result->shape[1], matrix->shape[0]);
9178 :
9179 45 : if (matrix->ts.type == BT_CHARACTER)
9180 18 : result->ts.u.cl = matrix->ts.u.cl;
9181 27 : else if (matrix->ts.type == BT_DERIVED)
9182 7 : result->ts.u.derived = matrix->ts.u.derived;
9183 :
9184 45 : matrix_rows = mpz_get_si (matrix->shape[0]);
9185 45 : matrix_cols = mpz_get_si (matrix->shape[1]);
9186 201 : for (row = 0; row < matrix_rows; ++row)
9187 530 : for (col = 0; col < matrix_cols; ++col)
9188 : {
9189 748 : gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
9190 374 : col * matrix_rows + row);
9191 374 : gfc_constructor_insert_expr (&result->value.constructor,
9192 : gfc_copy_expr (e), &matrix->where,
9193 374 : row * matrix_cols + col);
9194 : }
9195 :
9196 : return result;
9197 : }
9198 :
9199 :
9200 : gfc_expr *
9201 4598 : gfc_simplify_trim (gfc_expr *e)
9202 : {
9203 4598 : gfc_expr *result;
9204 4598 : int count, i, len, lentrim;
9205 :
9206 4598 : if (e->expr_type != EXPR_CONSTANT)
9207 : return NULL;
9208 :
9209 44 : len = e->value.character.length;
9210 196 : for (count = 0, i = 1; i <= len; ++i)
9211 : {
9212 196 : if (e->value.character.string[len - i] == ' ')
9213 152 : count++;
9214 : else
9215 : break;
9216 : }
9217 :
9218 44 : lentrim = len - count;
9219 :
9220 44 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
9221 769 : for (i = 0; i < lentrim; i++)
9222 681 : result->value.character.string[i] = e->value.character.string[i];
9223 :
9224 : return result;
9225 : }
9226 :
9227 :
9228 : gfc_expr *
9229 282 : gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub,
9230 : gfc_expr *team_or_team_number ATTRIBUTE_UNUSED)
9231 : {
9232 282 : gfc_expr *result;
9233 282 : gfc_ref *ref;
9234 282 : gfc_array_spec *as;
9235 282 : gfc_constructor *sub_cons;
9236 282 : bool first_image;
9237 282 : int d;
9238 :
9239 282 : if (!is_constant_array_expr (sub))
9240 : return NULL;
9241 :
9242 : /* Follow any component references. */
9243 276 : as = coarray->symtree->n.sym->as;
9244 554 : for (ref = coarray->ref; ref; ref = ref->next)
9245 278 : if (ref->type == REF_COMPONENT)
9246 2 : as = ref->u.ar.as;
9247 :
9248 276 : if (!as || as->type == AS_DEFERRED)
9249 : return NULL;
9250 :
9251 : /* "valid sequence of cosubscripts" are required; thus, return 0 unless
9252 : the cosubscript addresses the first image. */
9253 :
9254 163 : sub_cons = gfc_constructor_first (sub->value.constructor);
9255 163 : first_image = true;
9256 :
9257 359 : for (d = 1; d <= as->corank; d++)
9258 : {
9259 252 : gfc_expr *ca_bound;
9260 252 : int cmp;
9261 :
9262 252 : gcc_assert (sub_cons != NULL);
9263 :
9264 252 : ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
9265 : NULL, true);
9266 252 : if (ca_bound == NULL)
9267 : return NULL;
9268 :
9269 198 : if (ca_bound == &gfc_bad_expr)
9270 : return ca_bound;
9271 :
9272 198 : cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
9273 :
9274 198 : if (cmp == 0)
9275 : {
9276 136 : gfc_free_expr (ca_bound);
9277 136 : sub_cons = gfc_constructor_next (sub_cons);
9278 136 : continue;
9279 : }
9280 :
9281 62 : first_image = false;
9282 :
9283 62 : if (cmp > 0)
9284 : {
9285 1 : gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
9286 : "SUB has %ld and COARRAY lower bound is %ld)",
9287 : &coarray->where, d,
9288 : mpz_get_si (sub_cons->expr->value.integer),
9289 : mpz_get_si (ca_bound->value.integer));
9290 1 : gfc_free_expr (ca_bound);
9291 1 : return &gfc_bad_expr;
9292 : }
9293 :
9294 61 : gfc_free_expr (ca_bound);
9295 :
9296 : /* Check whether upperbound is valid for the multi-images case. */
9297 61 : if (d < as->corank)
9298 : {
9299 27 : ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
9300 : NULL, true);
9301 27 : if (ca_bound == &gfc_bad_expr)
9302 : return ca_bound;
9303 :
9304 27 : if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
9305 27 : && mpz_cmp (ca_bound->value.integer,
9306 27 : sub_cons->expr->value.integer) < 0)
9307 : {
9308 1 : gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
9309 : "SUB has %ld and COARRAY upper bound is %ld)",
9310 : &coarray->where, d,
9311 : mpz_get_si (sub_cons->expr->value.integer),
9312 : mpz_get_si (ca_bound->value.integer));
9313 1 : gfc_free_expr (ca_bound);
9314 1 : return &gfc_bad_expr;
9315 : }
9316 :
9317 : if (ca_bound)
9318 26 : gfc_free_expr (ca_bound);
9319 : }
9320 :
9321 60 : sub_cons = gfc_constructor_next (sub_cons);
9322 : }
9323 :
9324 107 : gcc_assert (sub_cons == NULL);
9325 :
9326 107 : if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image)
9327 : return NULL;
9328 :
9329 85 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
9330 : &gfc_current_locus);
9331 85 : if (first_image)
9332 52 : mpz_set_si (result->value.integer, 1);
9333 : else
9334 33 : mpz_set_si (result->value.integer, 0);
9335 :
9336 : return result;
9337 : }
9338 :
9339 : gfc_expr *
9340 110 : gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED)
9341 : {
9342 110 : if (flag_coarray == GFC_FCOARRAY_NONE)
9343 : {
9344 0 : gfc_current_locus = *gfc_current_intrinsic_where;
9345 0 : gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
9346 : return &gfc_bad_expr;
9347 : }
9348 :
9349 : /* Simplification is possible for fcoarray = single only. For all other modes
9350 : the result depends on runtime conditions. */
9351 110 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
9352 : return NULL;
9353 :
9354 15 : if (gfc_is_constant_expr (image))
9355 : {
9356 7 : gfc_expr *result;
9357 7 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
9358 : &image->where);
9359 7 : if (mpz_get_si (image->value.integer) == 1)
9360 3 : mpz_set_si (result->value.integer, 0);
9361 : else
9362 4 : mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE);
9363 7 : return result;
9364 : }
9365 : else
9366 : return NULL;
9367 : }
9368 :
9369 :
9370 : gfc_expr *
9371 3557 : gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
9372 : gfc_expr *team ATTRIBUTE_UNUSED)
9373 : {
9374 3557 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
9375 : return NULL;
9376 :
9377 : /* If no coarray argument has been passed. */
9378 1098 : if (coarray == NULL)
9379 : {
9380 594 : gfc_expr *result;
9381 : /* FIXME: gfc_current_locus is wrong. */
9382 594 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
9383 : &gfc_current_locus);
9384 594 : mpz_set_si (result->value.integer, 1);
9385 594 : return result;
9386 : }
9387 :
9388 : /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
9389 504 : return simplify_cobound (coarray, dim, NULL, 0);
9390 : }
9391 :
9392 :
9393 : gfc_expr *
9394 14989 : gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
9395 : {
9396 14989 : return simplify_bound (array, dim, kind, 1);
9397 : }
9398 :
9399 : gfc_expr *
9400 594 : gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
9401 : {
9402 594 : return simplify_cobound (array, dim, kind, 1);
9403 : }
9404 :
9405 :
9406 : gfc_expr *
9407 480 : gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
9408 : {
9409 480 : gfc_expr *result, *e;
9410 480 : gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
9411 :
9412 480 : if (!is_constant_array_expr (vector)
9413 242 : || !is_constant_array_expr (mask)
9414 503 : || (!gfc_is_constant_expr (field)
9415 12 : && !is_constant_array_expr (field)))
9416 457 : return NULL;
9417 :
9418 23 : result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
9419 : &vector->where);
9420 23 : if (vector->ts.type == BT_DERIVED)
9421 4 : result->ts.u.derived = vector->ts.u.derived;
9422 23 : result->rank = mask->rank;
9423 23 : result->shape = gfc_copy_shape (mask->shape, mask->rank);
9424 :
9425 23 : if (vector->ts.type == BT_CHARACTER)
9426 0 : result->ts.u.cl = vector->ts.u.cl;
9427 :
9428 23 : vector_ctor = gfc_constructor_first (vector->value.constructor);
9429 23 : mask_ctor = gfc_constructor_first (mask->value.constructor);
9430 23 : field_ctor
9431 23 : = field->expr_type == EXPR_ARRAY
9432 23 : ? gfc_constructor_first (field->value.constructor)
9433 : : NULL;
9434 :
9435 168 : while (mask_ctor)
9436 : {
9437 151 : if (mask_ctor->expr->value.logical)
9438 : {
9439 55 : if (vector_ctor)
9440 : {
9441 52 : e = gfc_copy_expr (vector_ctor->expr);
9442 52 : vector_ctor = gfc_constructor_next (vector_ctor);
9443 : }
9444 : else
9445 : {
9446 3 : gfc_free_expr (result);
9447 3 : return NULL;
9448 : }
9449 : }
9450 96 : else if (field->expr_type == EXPR_ARRAY)
9451 : {
9452 52 : if (field_ctor)
9453 49 : e = gfc_copy_expr (field_ctor->expr);
9454 : else
9455 : {
9456 : /* Not enough elements in array FIELD. */
9457 3 : gfc_free_expr (result);
9458 3 : return &gfc_bad_expr;
9459 : }
9460 : }
9461 : else
9462 44 : e = gfc_copy_expr (field);
9463 :
9464 145 : gfc_constructor_append_expr (&result->value.constructor, e, NULL);
9465 :
9466 145 : mask_ctor = gfc_constructor_next (mask_ctor);
9467 145 : field_ctor = gfc_constructor_next (field_ctor);
9468 : }
9469 :
9470 : return result;
9471 : }
9472 :
9473 :
9474 : gfc_expr *
9475 410 : gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
9476 : {
9477 410 : gfc_expr *result;
9478 410 : int back;
9479 410 : size_t index, len, lenset;
9480 410 : size_t i;
9481 410 : int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
9482 :
9483 410 : if (k == -1)
9484 : return &gfc_bad_expr;
9485 :
9486 410 : if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
9487 158 : || ( b != NULL && b->expr_type != EXPR_CONSTANT))
9488 : return NULL;
9489 :
9490 150 : if (b != NULL && b->value.logical != 0)
9491 : back = 1;
9492 : else
9493 78 : back = 0;
9494 :
9495 156 : result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
9496 :
9497 156 : len = s->value.character.length;
9498 156 : lenset = set->value.character.length;
9499 :
9500 156 : if (len == 0)
9501 : {
9502 0 : mpz_set_ui (result->value.integer, 0);
9503 0 : return result;
9504 : }
9505 :
9506 156 : if (back == 0)
9507 : {
9508 78 : if (lenset == 0)
9509 : {
9510 18 : mpz_set_ui (result->value.integer, 1);
9511 18 : return result;
9512 : }
9513 :
9514 60 : index = wide_strspn (s->value.character.string,
9515 60 : set->value.character.string) + 1;
9516 60 : if (index > len)
9517 0 : index = 0;
9518 :
9519 : }
9520 : else
9521 : {
9522 78 : if (lenset == 0)
9523 : {
9524 18 : mpz_set_ui (result->value.integer, len);
9525 18 : return result;
9526 : }
9527 96 : for (index = len; index > 0; index --)
9528 : {
9529 300 : for (i = 0; i < lenset; i++)
9530 : {
9531 240 : if (s->value.character.string[index - 1]
9532 240 : == set->value.character.string[i])
9533 : break;
9534 : }
9535 96 : if (i == lenset)
9536 : break;
9537 : }
9538 : }
9539 :
9540 120 : mpz_set_ui (result->value.integer, index);
9541 120 : return result;
9542 : }
9543 :
9544 :
9545 : gfc_expr *
9546 26 : gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
9547 : {
9548 26 : gfc_expr *result;
9549 26 : int kind;
9550 :
9551 26 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
9552 : return NULL;
9553 :
9554 6 : kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
9555 :
9556 6 : switch (x->ts.type)
9557 : {
9558 0 : case BT_INTEGER:
9559 0 : result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
9560 0 : mpz_xor (result->value.integer, x->value.integer, y->value.integer);
9561 0 : return range_check (result, "XOR");
9562 :
9563 6 : case BT_LOGICAL:
9564 6 : return gfc_get_logical_expr (kind, &x->where,
9565 6 : (x->value.logical && !y->value.logical)
9566 18 : || (!x->value.logical && y->value.logical));
9567 :
9568 0 : default:
9569 0 : gcc_unreachable ();
9570 : }
9571 : }
9572 :
9573 :
9574 : /****************** Constant simplification *****************/
9575 :
9576 : /* Master function to convert one constant to another. While this is
9577 : used as a simplification function, it requires the destination type
9578 : and kind information which is supplied by a special case in
9579 : do_simplify(). */
9580 :
9581 : gfc_expr *
9582 165049 : gfc_convert_constant (gfc_expr *e, bt type, int kind)
9583 : {
9584 165049 : gfc_expr *result, *(*f) (gfc_expr *, int);
9585 165049 : gfc_constructor *c, *t;
9586 :
9587 165049 : switch (e->ts.type)
9588 : {
9589 144114 : case BT_INTEGER:
9590 144114 : switch (type)
9591 : {
9592 : case BT_INTEGER:
9593 : f = gfc_int2int;
9594 : break;
9595 152 : case BT_UNSIGNED:
9596 152 : f = gfc_int2uint;
9597 152 : break;
9598 63129 : case BT_REAL:
9599 63129 : f = gfc_int2real;
9600 63129 : break;
9601 1438 : case BT_COMPLEX:
9602 1438 : f = gfc_int2complex;
9603 1438 : break;
9604 0 : case BT_LOGICAL:
9605 0 : f = gfc_int2log;
9606 0 : break;
9607 0 : default:
9608 0 : goto oops;
9609 : }
9610 : break;
9611 :
9612 596 : case BT_UNSIGNED:
9613 596 : switch (type)
9614 : {
9615 : case BT_INTEGER:
9616 : f = gfc_uint2int;
9617 : break;
9618 223 : case BT_UNSIGNED:
9619 223 : f = gfc_uint2uint;
9620 223 : break;
9621 48 : case BT_REAL:
9622 48 : f = gfc_uint2real;
9623 48 : break;
9624 0 : case BT_COMPLEX:
9625 0 : f = gfc_uint2complex;
9626 0 : break;
9627 0 : case BT_LOGICAL:
9628 0 : f = gfc_uint2log;
9629 0 : break;
9630 0 : default:
9631 0 : goto oops;
9632 : }
9633 : break;
9634 :
9635 13312 : case BT_REAL:
9636 13312 : switch (type)
9637 : {
9638 : case BT_INTEGER:
9639 : f = gfc_real2int;
9640 : break;
9641 6 : case BT_UNSIGNED:
9642 6 : f = gfc_real2uint;
9643 6 : break;
9644 10401 : case BT_REAL:
9645 10401 : f = gfc_real2real;
9646 10401 : break;
9647 2005 : case BT_COMPLEX:
9648 2005 : f = gfc_real2complex;
9649 2005 : break;
9650 0 : default:
9651 0 : goto oops;
9652 : }
9653 : break;
9654 :
9655 2914 : case BT_COMPLEX:
9656 2914 : switch (type)
9657 : {
9658 : case BT_INTEGER:
9659 : f = gfc_complex2int;
9660 : break;
9661 6 : case BT_UNSIGNED:
9662 6 : f = gfc_complex2uint;
9663 6 : break;
9664 204 : case BT_REAL:
9665 204 : f = gfc_complex2real;
9666 204 : break;
9667 2648 : case BT_COMPLEX:
9668 2648 : f = gfc_complex2complex;
9669 2648 : break;
9670 :
9671 0 : default:
9672 0 : goto oops;
9673 : }
9674 : break;
9675 :
9676 2023 : case BT_LOGICAL:
9677 2023 : switch (type)
9678 : {
9679 : case BT_INTEGER:
9680 : f = gfc_log2int;
9681 : break;
9682 0 : case BT_UNSIGNED:
9683 0 : f = gfc_log2uint;
9684 0 : break;
9685 1793 : case BT_LOGICAL:
9686 1793 : f = gfc_log2log;
9687 1793 : break;
9688 0 : default:
9689 0 : goto oops;
9690 : }
9691 : break;
9692 :
9693 1330 : case BT_HOLLERITH:
9694 1330 : switch (type)
9695 : {
9696 : case BT_INTEGER:
9697 : f = gfc_hollerith2int;
9698 : break;
9699 :
9700 : /* Hollerith is for legacy code, we do not currently support
9701 : converting this to UNSIGNED. */
9702 0 : case BT_UNSIGNED:
9703 0 : goto oops;
9704 :
9705 327 : case BT_REAL:
9706 327 : f = gfc_hollerith2real;
9707 327 : break;
9708 :
9709 288 : case BT_COMPLEX:
9710 288 : f = gfc_hollerith2complex;
9711 288 : break;
9712 :
9713 146 : case BT_CHARACTER:
9714 146 : f = gfc_hollerith2character;
9715 146 : break;
9716 :
9717 195 : case BT_LOGICAL:
9718 195 : f = gfc_hollerith2logical;
9719 195 : break;
9720 :
9721 0 : default:
9722 0 : goto oops;
9723 : }
9724 : break;
9725 :
9726 747 : case BT_CHARACTER:
9727 747 : switch (type)
9728 : {
9729 : case BT_INTEGER:
9730 : f = gfc_character2int;
9731 : break;
9732 :
9733 0 : case BT_UNSIGNED:
9734 0 : goto oops;
9735 :
9736 187 : case BT_REAL:
9737 187 : f = gfc_character2real;
9738 187 : break;
9739 :
9740 187 : case BT_COMPLEX:
9741 187 : f = gfc_character2complex;
9742 187 : break;
9743 :
9744 0 : case BT_CHARACTER:
9745 0 : f = gfc_character2character;
9746 0 : break;
9747 :
9748 186 : case BT_LOGICAL:
9749 186 : f = gfc_character2logical;
9750 186 : break;
9751 :
9752 0 : default:
9753 0 : goto oops;
9754 : }
9755 : break;
9756 :
9757 : default:
9758 165049 : oops:
9759 : return &gfc_bad_expr;
9760 : }
9761 :
9762 165036 : result = NULL;
9763 :
9764 165036 : switch (e->expr_type)
9765 : {
9766 127830 : case EXPR_CONSTANT:
9767 127830 : result = f (e, kind);
9768 127830 : if (result == NULL)
9769 : return &gfc_bad_expr;
9770 : break;
9771 :
9772 4951 : case EXPR_ARRAY:
9773 4951 : if (!gfc_is_constant_expr (e))
9774 : break;
9775 :
9776 4777 : result = gfc_get_array_expr (type, kind, &e->where);
9777 4777 : result->shape = gfc_copy_shape (e->shape, e->rank);
9778 4777 : result->rank = e->rank;
9779 :
9780 4777 : for (c = gfc_constructor_first (e->value.constructor);
9781 60150 : c; c = gfc_constructor_next (c))
9782 : {
9783 55410 : gfc_expr *tmp;
9784 55410 : if (c->iterator == NULL)
9785 : {
9786 55387 : if (c->expr->expr_type == EXPR_ARRAY)
9787 69 : tmp = gfc_convert_constant (c->expr, type, kind);
9788 55318 : else if (c->expr->expr_type == EXPR_OP)
9789 : {
9790 29 : if (!gfc_simplify_expr (c->expr, 1))
9791 : return &gfc_bad_expr;
9792 29 : tmp = f (c->expr, kind);
9793 : }
9794 : else
9795 55289 : tmp = f (c->expr, kind);
9796 : }
9797 : else
9798 23 : tmp = gfc_convert_constant (c->expr, type, kind);
9799 :
9800 55410 : if (tmp == NULL || tmp == &gfc_bad_expr)
9801 : {
9802 37 : gfc_free_expr (result);
9803 37 : return NULL;
9804 : }
9805 :
9806 55373 : t = gfc_constructor_append_expr (&result->value.constructor,
9807 : tmp, &c->where);
9808 55373 : if (c->iterator)
9809 4 : t->iterator = gfc_copy_iterator (c->iterator);
9810 : }
9811 :
9812 : break;
9813 :
9814 : default:
9815 : break;
9816 : }
9817 :
9818 : return result;
9819 : }
9820 :
9821 :
9822 : /* Function for converting character constants. */
9823 : gfc_expr *
9824 214 : gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
9825 : {
9826 214 : gfc_expr *result;
9827 214 : int i;
9828 :
9829 214 : if (!gfc_is_constant_expr (e))
9830 : return NULL;
9831 :
9832 214 : if (e->expr_type == EXPR_CONSTANT)
9833 : {
9834 : /* Simple case of a scalar. */
9835 201 : result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
9836 201 : if (result == NULL)
9837 : return &gfc_bad_expr;
9838 :
9839 201 : result->value.character.length = e->value.character.length;
9840 201 : result->value.character.string
9841 201 : = gfc_get_wide_string (e->value.character.length + 1);
9842 201 : memcpy (result->value.character.string, e->value.character.string,
9843 201 : (e->value.character.length + 1) * sizeof (gfc_char_t));
9844 :
9845 : /* Check we only have values representable in the destination kind. */
9846 1189 : for (i = 0; i < result->value.character.length; i++)
9847 992 : if (!gfc_check_character_range (result->value.character.string[i],
9848 : kind))
9849 : {
9850 4 : gfc_error ("Character %qs in string at %L cannot be converted "
9851 : "into character kind %d",
9852 4 : gfc_print_wide_char (result->value.character.string[i]),
9853 : &e->where, kind);
9854 4 : gfc_free_expr (result);
9855 4 : return &gfc_bad_expr;
9856 : }
9857 :
9858 : return result;
9859 : }
9860 13 : else if (e->expr_type == EXPR_ARRAY)
9861 : {
9862 : /* For an array constructor, we convert each constructor element. */
9863 13 : gfc_constructor *c;
9864 :
9865 13 : result = gfc_get_array_expr (type, kind, &e->where);
9866 13 : result->shape = gfc_copy_shape (e->shape, e->rank);
9867 13 : result->rank = e->rank;
9868 13 : result->ts.u.cl = e->ts.u.cl;
9869 :
9870 13 : for (c = gfc_constructor_first (e->value.constructor);
9871 40 : c; c = gfc_constructor_next (c))
9872 : {
9873 27 : gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
9874 27 : if (tmp == &gfc_bad_expr)
9875 : {
9876 0 : gfc_free_expr (result);
9877 0 : return &gfc_bad_expr;
9878 : }
9879 :
9880 27 : if (tmp == NULL)
9881 : {
9882 0 : gfc_free_expr (result);
9883 0 : return NULL;
9884 : }
9885 :
9886 27 : gfc_constructor_append_expr (&result->value.constructor,
9887 : tmp, &c->where);
9888 : }
9889 :
9890 : return result;
9891 : }
9892 : else
9893 : return NULL;
9894 : }
9895 :
9896 :
9897 : gfc_expr *
9898 8 : gfc_simplify_compiler_options (void)
9899 : {
9900 8 : char *str;
9901 8 : gfc_expr *result;
9902 :
9903 8 : str = gfc_get_option_string ();
9904 16 : result = gfc_get_character_expr (gfc_default_character_kind,
9905 8 : &gfc_current_locus, str, strlen (str));
9906 8 : free (str);
9907 8 : return result;
9908 : }
9909 :
9910 :
9911 : gfc_expr *
9912 10 : gfc_simplify_compiler_version (void)
9913 : {
9914 10 : char *buffer;
9915 10 : size_t len;
9916 :
9917 10 : len = strlen ("GCC version ") + strlen (version_string);
9918 10 : buffer = XALLOCAVEC (char, len + 1);
9919 10 : snprintf (buffer, len + 1, "GCC version %s", version_string);
9920 10 : return gfc_get_character_expr (gfc_default_character_kind,
9921 10 : &gfc_current_locus, buffer, len);
9922 : }
9923 :
9924 : /* Simplification routines for intrinsics of IEEE modules. */
9925 :
9926 : gfc_expr *
9927 243 : simplify_ieee_selected_real_kind (gfc_expr *expr)
9928 : {
9929 243 : gfc_actual_arglist *arg;
9930 243 : gfc_expr *p = NULL, *q = NULL, *rdx = NULL;
9931 :
9932 243 : arg = expr->value.function.actual;
9933 243 : p = arg->expr;
9934 243 : if (arg->next)
9935 : {
9936 241 : q = arg->next->expr;
9937 241 : if (arg->next->next)
9938 241 : rdx = arg->next->next->expr;
9939 : }
9940 :
9941 : /* Currently, if IEEE is supported and this module is built, it means
9942 : all our floating-point types conform to IEEE. Hence, we simply handle
9943 : IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
9944 243 : return gfc_simplify_selected_real_kind (p, q, rdx);
9945 : }
9946 :
9947 : gfc_expr *
9948 102 : simplify_ieee_support (gfc_expr *expr)
9949 : {
9950 : /* We consider that if the IEEE modules are loaded, we have full support
9951 : for flags, halting and rounding, which are the three functions
9952 : (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
9953 : expressions. One day, we will need libgfortran to detect support and
9954 : communicate it back to us, allowing for partial support. */
9955 :
9956 102 : return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where,
9957 102 : true);
9958 : }
9959 :
9960 : bool
9961 993 : matches_ieee_function_name (gfc_symbol *sym, const char *name)
9962 : {
9963 993 : int n = strlen(name);
9964 :
9965 993 : if (!strncmp(sym->name, name, n))
9966 : return true;
9967 :
9968 : /* If a generic was used and renamed, we need more work to find out.
9969 : Compare the specific name. */
9970 654 : if (sym->generic && !strncmp(sym->generic->sym->name, name, n))
9971 6 : return true;
9972 :
9973 : return false;
9974 : }
9975 :
9976 : gfc_expr *
9977 453 : gfc_simplify_ieee_functions (gfc_expr *expr)
9978 : {
9979 453 : gfc_symbol* sym = expr->symtree->n.sym;
9980 :
9981 453 : if (matches_ieee_function_name(sym, "ieee_selected_real_kind"))
9982 243 : return simplify_ieee_selected_real_kind (expr);
9983 210 : else if (matches_ieee_function_name(sym, "ieee_support_flag")
9984 174 : || matches_ieee_function_name(sym, "ieee_support_halting")
9985 366 : || matches_ieee_function_name(sym, "ieee_support_rounding"))
9986 102 : return simplify_ieee_support (expr);
9987 : else
9988 : return NULL;
9989 : }
|
