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 342270 : range_check (gfc_expr *result, const char *name)
79 : {
80 342270 : if (result == NULL)
81 : return &gfc_bad_expr;
82 :
83 342270 : if (result->expr_type != EXPR_CONSTANT)
84 : return result;
85 :
86 342250 : 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 155052 : get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
121 : {
122 155052 : int kind;
123 :
124 155052 : if (k == NULL)
125 : return default_kind;
126 :
127 33948 : 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 33948 : if (gfc_extract_int (k, &kind)
135 33948 : || 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 33948 : 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 135318 : is_constant_array_expr (gfc_expr *e)
221 : {
222 135318 : gfc_constructor *c;
223 135318 : bool array_OK = true;
224 135318 : mpz_t size;
225 :
226 135318 : if (e == NULL)
227 : return true;
228 :
229 121777 : if (e->expr_type == EXPR_VARIABLE && e->rank > 0
230 45645 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
231 3352 : gfc_simplify_expr (e, 1);
232 :
233 121777 : if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
234 : return false;
235 :
236 : /* A non-zero-sized constant array shall have a non-empty constructor. */
237 29421 : if (e->rank > 0 && e->shape != NULL && e->value.constructor == NULL)
238 : {
239 1219 : mpz_init_set_ui (size, 1);
240 3867 : 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 29418 : for (c = gfc_constructor_first (e->value.constructor);
249 511426 : c; c = gfc_constructor_next (c))
250 482031 : 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 29418 : bool expand;
260 58836 : expand = (e->rank == 1
261 28475 : && e->shape
262 57882 : && (mpz_cmp_ui (e->shape[0], flag_max_array_constructor) < 0));
263 :
264 29418 : 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 11290 : gfc_is_constant_array_expr (gfc_expr *e)
296 : {
297 11290 : return is_constant_array_expr (e);
298 : }
299 :
300 :
301 : /* Test for a size zero array. */
302 : bool
303 173850 : gfc_is_size_zero_array (gfc_expr *array)
304 : {
305 :
306 173850 : if (array->rank == 0)
307 : return false;
308 :
309 168733 : if (array->expr_type == EXPR_VARIABLE && array->rank > 0
310 21839 : && array->symtree->n.sym->attr.flavor == FL_PARAMETER
311 10726 : && array->shape != NULL)
312 : {
313 22051 : for (int i = 0; i < array->rank; i++)
314 12486 : if (mpz_cmp_si (array->shape[i], 0) <= 0)
315 : return true;
316 :
317 : return false;
318 : }
319 :
320 158261 : if (array->expr_type == EXPR_ARRAY)
321 101881 : 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 4061 : init_result_expr (gfc_expr *e, int init, gfc_expr *array)
331 : {
332 4061 : 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 3836 : else if (e && e->expr_type == EXPR_CONSTANT)
342 : {
343 3836 : int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
344 3836 : HOST_WIDE_INT length;
345 3836 : gfc_char_t *string;
346 :
347 3836 : switch (e->ts.type)
348 : {
349 2249 : case BT_LOGICAL:
350 2249 : e->value.logical = (init ? 1 : 0);
351 2249 : break;
352 :
353 1029 : case BT_INTEGER:
354 1029 : if (init == INT_MIN)
355 144 : mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
356 885 : else if (init == INT_MAX)
357 158 : mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
358 : else
359 727 : 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 3836 : }
417 : else
418 0 : gcc_unreachable();
419 4061 : }
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 3263 : transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
493 : int kind, locus* where)
494 : {
495 3263 : gfc_expr *result;
496 3263 : int i, nelem;
497 :
498 3263 : if (!dim || array->rank == 1)
499 3038 : 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 2622 : simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
558 : transformational_op op)
559 : {
560 2622 : gfc_expr *a, *m;
561 2622 : gfc_constructor *array_ctor, *mask_ctor;
562 :
563 : /* Shortcut for constant .FALSE. MASK. */
564 2622 : if (mask
565 98 : && mask->expr_type == EXPR_CONSTANT
566 24 : && !mask->value.logical)
567 : return result;
568 :
569 2598 : array_ctor = gfc_constructor_first (array->value.constructor);
570 2598 : mask_ctor = NULL;
571 2598 : if (mask && mask->expr_type == EXPR_ARRAY)
572 74 : mask_ctor = gfc_constructor_first (mask->value.constructor);
573 :
574 71443 : while (array_ctor)
575 : {
576 68845 : a = array_ctor->expr;
577 68845 : array_ctor = gfc_constructor_next (array_ctor);
578 :
579 : /* A constant MASK equals .TRUE. here and can be ignored. */
580 68845 : 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 68541 : result = op (result, gfc_copy_expr (a));
589 68541 : 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 59132 : simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
746 : int init_val, transformational_op op)
747 : {
748 59132 : gfc_expr *result;
749 59132 : bool size_zero;
750 :
751 59132 : size_zero = gfc_is_size_zero_array (array);
752 :
753 115148 : if (!(is_constant_array_expr (array) || size_zero)
754 3116 : || array->shape == NULL
755 62241 : || !gfc_is_constant_expr (dim))
756 : return NULL;
757 :
758 3109 : if (mask
759 242 : && !is_constant_array_expr (mask)
760 3291 : && mask->expr_type != EXPR_CONSTANT)
761 : return NULL;
762 :
763 2951 : result = transformational_result (array, dim, array->ts.type,
764 : array->ts.kind, &array->where);
765 2951 : init_result_expr (result, init_val, array);
766 :
767 2951 : if (size_zero)
768 : return result;
769 :
770 2704 : return !dim || array->rank == 1 ?
771 2561 : simplify_transformation_to_scalar (result, array, mask, op) :
772 2704 : simplify_transformation_to_array (result, array, dim, mask, op, NULL);
773 : }
774 :
775 :
776 : /********************** Simplification functions *****************************/
777 :
778 : gfc_expr *
779 25836 : gfc_simplify_abs (gfc_expr *e)
780 : {
781 25836 : gfc_expr *result;
782 :
783 25836 : 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 22230 : simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
812 : {
813 22230 : gfc_expr *result;
814 22230 : int kind;
815 22230 : bool too_large = false;
816 :
817 22230 : if (e->expr_type != EXPR_CONSTANT)
818 : return NULL;
819 :
820 14621 : kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
821 14621 : if (kind == -1)
822 : return &gfc_bad_expr;
823 :
824 14621 : 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 14613 : 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 14613 : if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
837 : too_large = true;
838 14604 : else if (kind == 4)
839 : {
840 1486 : mpz_t t;
841 1486 : mpz_init_set_ui (t, 2);
842 1486 : mpz_pow_ui (t, t, 32);
843 1486 : mpz_sub_ui (t, t, 1);
844 1486 : if (mpz_cmp (e->value.integer, t) > 0)
845 2 : too_large = true;
846 1486 : mpz_clear (t);
847 : }
848 :
849 1486 : 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 14602 : result = gfc_get_character_expr (kind, &e->where, NULL, 1);
857 14602 : result->value.character.string[0] = mpz_get_ui (e->value.integer);
858 :
859 14602 : 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 13388 : gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
869 : {
870 13388 : return simplify_achar_char (e, k, "ACHAR", true);
871 : }
872 :
873 :
874 : gfc_expr *
875 558 : gfc_simplify_acos (gfc_expr *x)
876 : {
877 558 : gfc_expr *result;
878 :
879 558 : if (x->expr_type != EXPR_CONSTANT)
880 : return NULL;
881 :
882 94 : switch (x->ts.type)
883 : {
884 90 : case BT_REAL:
885 90 : if (mpfr_cmp_si (x->value.real, 1) > 0
886 90 : || 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 90 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
894 90 : mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
895 90 : 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 94 : 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 1173 : gfc_simplify_adjustl (gfc_expr *e)
945 : {
946 1173 : gfc_expr *result;
947 1173 : int count, i, len;
948 1173 : gfc_char_t ch;
949 :
950 1173 : 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 1773 : gfc_simplify_aimag (gfc_expr *e)
1004 : {
1005 1773 : gfc_expr *result;
1006 :
1007 1773 : 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 1352 : gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
1043 : {
1044 1352 : 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 44447 : gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
1132 : {
1133 44447 : 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 207 : gfc_simplify_acosd (gfc_expr *x)
1209 : {
1210 207 : gfc_expr *result;
1211 :
1212 207 : 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 207 : gfc_simplify_asind (gfc_expr *x)
1240 : {
1241 207 : gfc_expr *result;
1242 :
1243 207 : 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 206 : gfc_simplify_atand (gfc_expr *x)
1271 : {
1272 206 : gfc_expr *result;
1273 :
1274 206 : 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 364 : 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 7125 : simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1857 : {
1858 7125 : gfc_expr *result;
1859 :
1860 7125 : if (x->expr_type != EXPR_CONSTANT
1861 5511 : || (y != NULL && y->expr_type != EXPR_CONSTANT))
1862 : return NULL;
1863 :
1864 5305 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
1865 :
1866 5305 : switch (x->ts.type)
1867 : {
1868 3766 : case BT_INTEGER:
1869 3766 : case BT_UNSIGNED:
1870 3766 : mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
1871 3766 : 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 5305 : if (!y)
1886 224 : return range_check (result, name);
1887 :
1888 5081 : switch (y->ts.type)
1889 : {
1890 3654 : case BT_INTEGER:
1891 3654 : case BT_UNSIGNED:
1892 3654 : mpfr_set_z (mpc_imagref (result->value.complex),
1893 3654 : y->value.integer, GFC_RND_MODE);
1894 3654 : 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 5081 : return range_check (result, name);
1906 : }
1907 :
1908 :
1909 : gfc_expr *
1910 6771 : gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1911 : {
1912 6771 : int kind;
1913 :
1914 6771 : kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
1915 6771 : if (kind == -1)
1916 : return &gfc_bad_expr;
1917 :
1918 6771 : 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 327 : gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
1961 : {
1962 327 : gfc_expr *result;
1963 :
1964 327 : 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 916 : gfc_simplify_cos (gfc_expr *x)
1989 : {
1990 916 : gfc_expr *result;
1991 :
1992 916 : if (x->expr_type != EXPR_CONSTANT)
1993 : return NULL;
1994 :
1995 166 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1996 :
1997 166 : switch (x->ts.type)
1998 : {
1999 109 : case BT_REAL:
2000 109 : mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
2001 109 : 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 166 : 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 219 : gfc_simplify_cosd (gfc_expr *x)
2041 : {
2042 219 : gfc_expr *result;
2043 :
2044 219 : 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 219 : gfc_simplify_sind (gfc_expr *x)
2063 : {
2064 219 : gfc_expr *result;
2065 :
2066 219 : 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 303 : gfc_simplify_tand (gfc_expr *x)
2085 : {
2086 303 : gfc_expr *result;
2087 :
2088 303 : 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 : 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 959 : gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
2441 : {
2442 959 : gfc_expr *result;
2443 959 : int which;
2444 959 : gfc_expr **arrayvec, **resultvec;
2445 959 : gfc_expr **rptr, **sptr;
2446 959 : mpz_t size;
2447 959 : size_t arraysize, shiftsize, i;
2448 959 : gfc_constructor *array_ctor, *shift_ctor;
2449 959 : ssize_t *shiftvec, *hptr;
2450 959 : ssize_t shift_val, len;
2451 959 : 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 959 : ssize_t rsoffset;
2458 959 : int d, n;
2459 959 : bool continue_loop;
2460 959 : gfc_expr **src, **dest;
2461 :
2462 959 : 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 644 : gfc_simplify_dble (gfc_expr *e)
2658 : {
2659 644 : gfc_expr *result = NULL;
2660 644 : int tmp1, tmp2;
2661 :
2662 644 : 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 : 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 142 : 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 3653 : gfc_simplify_epsilon (gfc_expr *e)
3305 : {
3306 3653 : gfc_expr *result;
3307 3653 : int i;
3308 :
3309 3653 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3310 :
3311 3653 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
3312 3653 : mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
3313 :
3314 3653 : return range_check (result, "EPSILON");
3315 : }
3316 :
3317 :
3318 : gfc_expr *
3319 1224 : gfc_simplify_exp (gfc_expr *x)
3320 : {
3321 1224 : gfc_expr *result;
3322 :
3323 1224 : 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 95 : gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED)
3416 : {
3417 95 : 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 95 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
3425 : {
3426 17 : gfc_expr *result;
3427 17 : result = gfc_get_null_expr (&gfc_current_locus);
3428 17 : result->ts.type = BT_DERIVED;
3429 17 : gfc_find_symbol ("team_type", gfc_current_ns, 1, &result->ts.u.derived);
3430 :
3431 17 : 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 2407 : is_last_ref_vtab (gfc_expr *e)
3456 : {
3457 2407 : gfc_ref *ref;
3458 2407 : gfc_component *comp = NULL;
3459 :
3460 2407 : if (e->expr_type != EXPR_VARIABLE)
3461 : return false;
3462 :
3463 3447 : for (ref = e->ref; ref; ref = ref->next)
3464 1058 : if (ref->type == REF_COMPONENT)
3465 444 : comp = ref->u.c.component;
3466 :
3467 2389 : if (!e->ref || !comp)
3468 1969 : 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 541 : gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
3479 : {
3480 : /* Avoid simplification of resolved symbols. */
3481 541 : 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 240 : || (mold->ts.type == BT_CLASS && !gfc_expr_attr (mold).class_ok))
3494 : 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 6283 : gfc_simplify_huge (gfc_expr *e)
3619 : {
3620 6283 : gfc_expr *result;
3621 6283 : int i;
3622 :
3623 6283 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3624 6283 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3625 :
3626 6283 : switch (e->ts.type)
3627 : {
3628 4675 : case BT_INTEGER:
3629 4675 : mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
3630 4675 : break;
3631 :
3632 156 : case BT_UNSIGNED:
3633 156 : mpz_set (result->value.integer, gfc_unsigned_kinds[i].huge);
3634 156 : break;
3635 :
3636 1452 : case BT_REAL:
3637 1452 : mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
3638 1452 : break;
3639 :
3640 0 : default:
3641 0 : gcc_unreachable ();
3642 : }
3643 :
3644 6283 : 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 7465 : simplify_intconv (gfc_expr *e, int kind, const char *name)
4045 : {
4046 7465 : gfc_expr *result = NULL;
4047 7465 : int tmp1, tmp2;
4048 :
4049 : /* Convert BOZ to integer, and return without range checking. */
4050 7465 : if (e->ts.type == BT_BOZ)
4051 : {
4052 1631 : if (!gfc_boz2int (e, kind))
4053 : return NULL;
4054 1631 : result = gfc_copy_expr (e);
4055 1631 : 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 7362 : gfc_simplify_int (gfc_expr *e, gfc_expr *k)
4081 : {
4082 7362 : int kind;
4083 :
4084 7362 : kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
4085 7362 : if (kind == -1)
4086 : return &gfc_bad_expr;
4087 :
4088 7362 : 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 1841 : gfc_simplify_ifix (gfc_expr *e)
4114 : {
4115 1841 : gfc_expr *rtrunc, *result;
4116 :
4117 1841 : if (e->expr_type != EXPR_CONSTANT)
4118 : return NULL;
4119 :
4120 131 : rtrunc = gfc_copy_expr (e);
4121 131 : mpfr_trunc (rtrunc->value.real, e->value.real);
4122 :
4123 131 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4124 : &e->where);
4125 131 : gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
4126 :
4127 131 : gfc_free_expr (rtrunc);
4128 :
4129 131 : return range_check (result, "IFIX");
4130 : }
4131 :
4132 :
4133 : gfc_expr *
4134 855 : gfc_simplify_idint (gfc_expr *e)
4135 : {
4136 855 : gfc_expr *rtrunc, *result;
4137 :
4138 855 : 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 : 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 5349 : gfc_simplify_kind (gfc_expr *e)
4524 : {
4525 5349 : return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
4526 : }
4527 :
4528 :
4529 : static gfc_expr *
4530 13435 : 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 13435 : gfc_expr *l, *u, *result;
4534 13435 : int k;
4535 :
4536 22474 : k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4537 : gfc_default_integer_kind);
4538 13435 : if (k == -1)
4539 : return &gfc_bad_expr;
4540 :
4541 13435 : 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 13435 : 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 12021 : gcc_assert (array->expr_type == EXPR_VARIABLE);
4565 12021 : gcc_assert (as);
4566 :
4567 12021 : if (!gfc_resolve_array_spec (as, 0))
4568 : return NULL;
4569 :
4570 : /* The last dimension of an assumed-size array is special. */
4571 12018 : if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
4572 1631 : || (coarray && d == as->rank + as->corank
4573 598 : && (!upper || flag_coarray == GFC_FCOARRAY_SINGLE)))
4574 : {
4575 684 : if (as->lower[d-1] && as->lower[d-1]->expr_type == EXPR_CONSTANT)
4576 : {
4577 457 : gfc_free_expr (result);
4578 457 : 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 10191 : if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
4586 : {
4587 10831 : gfc_expr *declared_bound;
4588 10831 : int empty_bound;
4589 10831 : bool constant_lbound, constant_ubound;
4590 :
4591 10831 : l = as->lower[d-1];
4592 10831 : u = as->upper[d-1];
4593 :
4594 10831 : gcc_assert (l != NULL);
4595 :
4596 10831 : constant_lbound = l->expr_type == EXPR_CONSTANT;
4597 10831 : constant_ubound = u && u->expr_type == EXPR_CONSTANT;
4598 :
4599 10831 : empty_bound = upper ? 0 : 1;
4600 10831 : declared_bound = upper ? u : l;
4601 :
4602 10831 : if ((!upper && !constant_lbound)
4603 9959 : || (upper && !constant_ubound))
4604 2242 : goto returnNull;
4605 :
4606 8589 : 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 7766 : if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0)
4613 3590 : mpz_set_si (result->value.integer, empty_bound);
4614 4176 : else if (!constant_lbound || !constant_ubound)
4615 : /* Array emptiness can't be determined, we can't simplify. */
4616 1815 : goto returnNull;
4617 2361 : else if (mpz_cmp (l->value.integer, u->value.integer) > 0)
4618 97 : mpz_set_si (result->value.integer, empty_bound);
4619 : else
4620 2264 : mpz_set (result->value.integer, declared_bound->value.integer);
4621 : }
4622 : else
4623 823 : 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 8243 : done:
4647 8243 : return range_check (result, upper ? "UBOUND" : "LBOUND");
4648 :
4649 4732 : returnNull:
4650 4732 : gfc_free_expr (result);
4651 4732 : return NULL;
4652 : }
4653 :
4654 :
4655 : static gfc_expr *
4656 35093 : simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4657 : {
4658 35093 : gfc_ref *ref;
4659 35093 : gfc_array_spec *as;
4660 35093 : ar_type type = AR_UNKNOWN;
4661 35093 : int d;
4662 :
4663 35093 : if (array->ts.type == BT_CLASS)
4664 : return NULL;
4665 :
4666 33647 : 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 32405 : if (array->symtree->n.sym->error)
4675 : return NULL;
4676 :
4677 : /* Follow any component references. */
4678 32404 : as = array->symtree->n.sym->as;
4679 33743 : for (ref = array->ref; ref; ref = ref->next)
4680 : {
4681 33743 : switch (ref->type)
4682 : {
4683 32538 : case REF_ARRAY:
4684 32538 : type = ref->u.ar.type;
4685 32538 : switch (ref->u.ar.type)
4686 : {
4687 134 : case AR_ELEMENT:
4688 134 : as = NULL;
4689 134 : continue;
4690 :
4691 31541 : case AR_FULL:
4692 : /* We're done because 'as' has already been set in the
4693 : previous iteration. */
4694 31541 : 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 1205 : case REF_COMPONENT:
4707 1205 : as = ref->u.c.component->as;
4708 1205 : continue;
4709 :
4710 0 : case REF_SUBSTRING:
4711 0 : case REF_INQUIRY:
4712 0 : continue;
4713 : }
4714 : }
4715 :
4716 0 : gcc_unreachable ();
4717 :
4718 33646 : done:
4719 :
4720 33646 : if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
4721 11443 : || (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 10485 : if (array->expr_type == EXPR_VARIABLE
4727 10485 : && (gfc_expr_attr (array).allocatable || gfc_expr_attr (array).pointer))
4728 : return NULL;
4729 :
4730 10479 : 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 10479 : 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 333 : 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 8900 : if (dim->expr_type != EXPR_CONSTANT)
4795 : return NULL;
4796 :
4797 8900 : d = mpz_get_si (dim->value.integer);
4798 :
4799 8900 : if ((d < 1 || d > array->rank)
4800 8900 : || (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 8483 : if (as && as->type == AS_ASSUMED_RANK)
4807 : return NULL;
4808 :
4809 8900 : return simplify_bound_dim (array, kind, d, upper, as, ref, false);
4810 : }
4811 : }
4812 :
4813 :
4814 : static gfc_expr *
4815 1866 : simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4816 : {
4817 1866 : gfc_ref *ref;
4818 1866 : gfc_array_spec *as;
4819 1866 : gfc_symbol *sym;
4820 1866 : int d;
4821 :
4822 1866 : if (array->expr_type != EXPR_VARIABLE)
4823 : return NULL;
4824 :
4825 : /* Do not attempt to resolve if an error has already been issued. */
4826 1866 : if (array->symtree->n.sym->error)
4827 : return NULL;
4828 :
4829 : /* Follow any component references, starting from the base symbol's array
4830 : spec; ARRAY itself may be a subobject of the coarray. */
4831 1866 : sym = array->symtree->n.sym;
4832 1866 : as = (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym))
4833 1866 : ? CLASS_DATA (sym)->as
4834 : : sym->as;
4835 2210 : for (ref = array->ref; ref; ref = ref->next)
4836 : {
4837 2206 : switch (ref->type)
4838 : {
4839 1862 : case REF_ARRAY:
4840 1862 : switch (ref->u.ar.type)
4841 : {
4842 583 : case AR_ELEMENT:
4843 583 : if (ref->u.ar.as->corank > 0)
4844 : {
4845 583 : as = ref->u.ar.as;
4846 583 : goto done;
4847 : }
4848 0 : as = NULL;
4849 0 : continue;
4850 :
4851 1279 : case AR_FULL:
4852 : /* We're done because 'as' has already been set in the
4853 : previous iteration. */
4854 1279 : goto done;
4855 :
4856 : case AR_UNKNOWN:
4857 : return NULL;
4858 :
4859 0 : case AR_SECTION:
4860 0 : as = ref->u.ar.as;
4861 0 : goto done;
4862 : }
4863 :
4864 0 : gcc_unreachable ();
4865 :
4866 344 : case REF_COMPONENT:
4867 344 : as = ref->u.c.component->as;
4868 344 : continue;
4869 :
4870 0 : case REF_SUBSTRING:
4871 0 : case REF_INQUIRY:
4872 0 : continue;
4873 : }
4874 : }
4875 :
4876 4 : done:
4877 :
4878 1866 : if (!as || as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
4879 : return NULL;
4880 :
4881 927 : if (dim == NULL)
4882 : {
4883 : /* Multi-dimensional cobounds. */
4884 : gfc_expr *bounds[GFC_MAX_DIMENSIONS];
4885 : gfc_expr *e;
4886 : int k;
4887 :
4888 : /* Simplify the cobounds for each dimension. */
4889 1044 : for (d = 0; d < as->corank; d++)
4890 : {
4891 902 : bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
4892 : upper, as, ref, true);
4893 902 : if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
4894 : {
4895 : int j;
4896 :
4897 436 : for (j = 0; j < d; j++)
4898 240 : gfc_free_expr (bounds[j]);
4899 : return bounds[d];
4900 : }
4901 : }
4902 :
4903 : /* Allocate the result expression. */
4904 142 : e = gfc_get_expr ();
4905 142 : e->where = array->where;
4906 142 : e->expr_type = EXPR_ARRAY;
4907 142 : e->ts.type = BT_INTEGER;
4908 259 : k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
4909 : gfc_default_integer_kind);
4910 142 : if (k == -1)
4911 : {
4912 0 : gfc_free_expr (e);
4913 0 : return &gfc_bad_expr;
4914 : }
4915 142 : e->ts.kind = k;
4916 :
4917 : /* The result is a rank 1 array; its size is the rank of the first
4918 : argument to {L,U}COBOUND. */
4919 142 : e->rank = 1;
4920 142 : e->shape = gfc_get_shape (1);
4921 142 : mpz_init_set_ui (e->shape[0], as->corank);
4922 :
4923 : /* Create the constructor for this array. */
4924 750 : for (d = 0; d < as->corank; d++)
4925 466 : gfc_constructor_append_expr (&e->value.constructor,
4926 : bounds[d], &e->where);
4927 : return e;
4928 : }
4929 : else
4930 : {
4931 : /* A DIM argument is specified. */
4932 589 : if (dim->expr_type != EXPR_CONSTANT)
4933 : return NULL;
4934 :
4935 449 : d = mpz_get_si (dim->value.integer);
4936 :
4937 449 : if (d < 1 || d > as->corank)
4938 : {
4939 0 : gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4940 0 : return &gfc_bad_expr;
4941 : }
4942 :
4943 449 : return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
4944 : }
4945 : }
4946 :
4947 :
4948 : gfc_expr *
4949 19809 : gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4950 : {
4951 19809 : return simplify_bound (array, dim, kind, 0);
4952 : }
4953 :
4954 :
4955 : gfc_expr *
4956 696 : gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4957 : {
4958 696 : return simplify_cobound (array, dim, kind, 0);
4959 : }
4960 :
4961 : gfc_expr *
4962 1068 : gfc_simplify_leadz (gfc_expr *e)
4963 : {
4964 1068 : unsigned long lz, bs;
4965 1068 : int i;
4966 :
4967 1068 : if (e->expr_type != EXPR_CONSTANT)
4968 : return NULL;
4969 :
4970 258 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4971 258 : bs = gfc_integer_kinds[i].bit_size;
4972 258 : if (mpz_cmp_si (e->value.integer, 0) == 0)
4973 : lz = bs;
4974 222 : else if (mpz_cmp_si (e->value.integer, 0) < 0)
4975 : lz = 0;
4976 : else
4977 132 : lz = bs - mpz_sizeinbase (e->value.integer, 2);
4978 :
4979 258 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
4980 : }
4981 :
4982 :
4983 : /* Check for constant length of a substring. */
4984 :
4985 : static bool
4986 17641 : substring_has_constant_len (gfc_expr *e)
4987 : {
4988 17641 : gfc_ref *ref;
4989 17641 : HOST_WIDE_INT istart, iend, length;
4990 17641 : bool equal_length = false;
4991 :
4992 17641 : if (e->ts.type != BT_CHARACTER)
4993 : return false;
4994 :
4995 25296 : for (ref = e->ref; ref; ref = ref->next)
4996 8187 : if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY)
4997 : break;
4998 :
4999 17641 : if (!ref
5000 532 : || ref->type != REF_SUBSTRING
5001 532 : || !ref->u.ss.start
5002 532 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
5003 208 : || !ref->u.ss.end
5004 208 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
5005 : return false;
5006 :
5007 : /* Basic checks on substring starting and ending indices. */
5008 207 : if (!gfc_resolve_substring (ref, &equal_length))
5009 : return false;
5010 :
5011 207 : istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer);
5012 207 : iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer);
5013 :
5014 207 : if (istart <= iend)
5015 199 : length = iend - istart + 1;
5016 : else
5017 : length = 0;
5018 :
5019 : /* Fix substring length. */
5020 207 : e->value.character.length = length;
5021 :
5022 207 : return true;
5023 : }
5024 :
5025 :
5026 : gfc_expr *
5027 18148 : gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
5028 : {
5029 18148 : gfc_expr *result;
5030 18148 : int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
5031 :
5032 18148 : if (k == -1)
5033 : return &gfc_bad_expr;
5034 :
5035 18148 : if (e->expr_type == EXPR_CONSTANT
5036 18148 : || substring_has_constant_len (e))
5037 : {
5038 714 : result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
5039 714 : mpz_set_si (result->value.integer, e->value.character.length);
5040 714 : return range_check (result, "LEN");
5041 : }
5042 17434 : else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
5043 5836 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
5044 3106 : && e->ts.u.cl->length->ts.type == BT_INTEGER)
5045 : {
5046 3106 : result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
5047 3106 : mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
5048 3106 : return range_check (result, "LEN");
5049 : }
5050 14328 : else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
5051 12442 : && e->symtree->n.sym)
5052 : {
5053 12442 : if (e->symtree->n.sym->ts.type != BT_DERIVED
5054 11994 : && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
5055 989 : && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
5056 367 : && e->symtree->n.sym->assoc->target->symtree->n.sym
5057 367 : && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
5058 : /* The expression in assoc->target points to a ref to the _data
5059 : component of the unlimited polymorphic entity. To get the _len
5060 : component the last _data ref needs to be stripped and a ref to the
5061 : _len component added. */
5062 367 : return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
5063 12075 : else if (e->symtree->n.sym->ts.type == BT_DERIVED
5064 448 : && e->ref && e->ref->type == REF_COMPONENT
5065 448 : && e->ref->u.c.component->attr.pdt_string
5066 72 : && e->ref->u.c.component->ts.type == BT_CHARACTER
5067 72 : && e->ref->u.c.component->ts.u.cl->length)
5068 : {
5069 72 : if (gfc_init_expr_flag)
5070 : {
5071 6 : gfc_expr* tmp;
5072 6 : tmp = gfc_pdt_find_component_copy_initializer (e->symtree->n.sym,
5073 : e->ref->u.c
5074 : .component->ts.u.cl
5075 6 : ->length->symtree
5076 : ->name);
5077 6 : if (tmp)
5078 : return tmp;
5079 : }
5080 : else
5081 : {
5082 66 : gfc_expr *len_expr = gfc_copy_expr (e);
5083 66 : gfc_free_ref_list (len_expr->ref);
5084 66 : len_expr->ref = NULL;
5085 66 : gfc_find_component (len_expr->symtree->n.sym->ts.u.derived, e->ref
5086 66 : ->u.c.component->ts.u.cl->length->symtree
5087 : ->name,
5088 : false, true, &len_expr->ref);
5089 66 : len_expr->ts = len_expr->ref->u.c.component->ts;
5090 66 : return len_expr;
5091 : }
5092 : }
5093 : }
5094 1886 : else if (e->expr_type == EXPR_ARRAY && e->ts.type == BT_CHARACTER
5095 127 : && e->ts.u.cl
5096 127 : && e->ts.u.cl->length_from_typespec
5097 126 : && e->ts.u.cl->length
5098 126 : && e->ts.u.cl->length->ts.type == BT_INTEGER)
5099 : {
5100 126 : gfc_typespec ts;
5101 126 : gfc_clear_ts (&ts);
5102 126 : ts.type = BT_INTEGER;
5103 126 : ts.kind = k;
5104 126 : result = gfc_copy_expr (e->ts.u.cl->length);
5105 126 : gfc_convert_type_warn (result, &ts, 2, 0);
5106 126 : return result;
5107 : }
5108 :
5109 : return NULL;
5110 : }
5111 :
5112 :
5113 : gfc_expr *
5114 4182 : gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
5115 : {
5116 4182 : gfc_expr *result;
5117 4182 : size_t count, len, i;
5118 4182 : int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
5119 :
5120 4182 : if (k == -1)
5121 : return &gfc_bad_expr;
5122 :
5123 : /* If the expression is either an array element or section, an array
5124 : parameter must be built so that the reference can be applied. Constant
5125 : references should have already been simplified away. All other cases
5126 : can proceed to translation, where kind conversion will occur silently. */
5127 4182 : if (e->expr_type == EXPR_VARIABLE
5128 3335 : && e->ts.type == BT_CHARACTER
5129 3335 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER
5130 129 : && e->ref && e->ref->type == REF_ARRAY
5131 129 : && e->ref->u.ar.type != AR_FULL
5132 82 : && e->symtree->n.sym->value)
5133 : {
5134 82 : char name[2*GFC_MAX_SYMBOL_LEN + 12];
5135 82 : gfc_namespace *ns = e->symtree->n.sym->ns;
5136 82 : gfc_symtree *st;
5137 82 : gfc_expr *expr;
5138 82 : gfc_expr *p;
5139 82 : gfc_constructor *c;
5140 82 : int cnt = 0;
5141 :
5142 82 : sprintf (name, "_len_trim_%s_%s", e->symtree->n.sym->name,
5143 82 : ns->proc_name->name);
5144 82 : st = gfc_find_symtree (ns->sym_root, name);
5145 82 : if (st)
5146 44 : goto already_built;
5147 :
5148 : /* Recursively call this fcn to simplify the constructor elements. */
5149 38 : expr = gfc_copy_expr (e->symtree->n.sym->value);
5150 38 : expr->ts.type = BT_INTEGER;
5151 38 : expr->ts.kind = k;
5152 38 : expr->ts.u.cl = NULL;
5153 38 : c = gfc_constructor_first (expr->value.constructor);
5154 237 : for (; c; c = gfc_constructor_next (c))
5155 : {
5156 161 : if (c->iterator)
5157 0 : continue;
5158 :
5159 161 : if (c->expr && c->expr->ts.type == BT_CHARACTER)
5160 : {
5161 161 : p = gfc_simplify_len_trim (c->expr, kind);
5162 161 : if (p == NULL)
5163 0 : goto clean_up;
5164 161 : gfc_replace_expr (c->expr, p);
5165 161 : cnt++;
5166 : }
5167 : }
5168 :
5169 38 : if (cnt)
5170 : {
5171 : /* Build a new parameter to take the result. */
5172 38 : st = gfc_new_symtree (&ns->sym_root, name);
5173 38 : st->n.sym = gfc_new_symbol (st->name, ns);
5174 38 : st->n.sym->value = expr;
5175 38 : st->n.sym->ts = expr->ts;
5176 38 : st->n.sym->attr.dimension = 1;
5177 38 : st->n.sym->attr.save = SAVE_IMPLICIT;
5178 38 : st->n.sym->attr.flavor = FL_PARAMETER;
5179 38 : st->n.sym->as = gfc_copy_array_spec (e->symtree->n.sym->as);
5180 38 : gfc_set_sym_referenced (st->n.sym);
5181 38 : st->n.sym->refs++;
5182 38 : gfc_commit_symbol (st->n.sym);
5183 :
5184 82 : already_built:
5185 : /* Build a return expression. */
5186 82 : expr = gfc_copy_expr (e);
5187 82 : expr->ts = st->n.sym->ts;
5188 82 : expr->symtree = st;
5189 82 : gfc_expression_rank (expr);
5190 82 : return expr;
5191 : }
5192 :
5193 0 : clean_up:
5194 0 : gfc_free_expr (expr);
5195 0 : return NULL;
5196 : }
5197 :
5198 4100 : if (e->expr_type != EXPR_CONSTANT)
5199 : return NULL;
5200 :
5201 388 : len = e->value.character.length;
5202 1215 : for (count = 0, i = 1; i <= len; i++)
5203 1203 : if (e->value.character.string[len - i] == ' ')
5204 827 : count++;
5205 : else
5206 : break;
5207 :
5208 388 : result = gfc_get_int_expr (k, &e->where, len - count);
5209 388 : return range_check (result, "LEN_TRIM");
5210 : }
5211 :
5212 : gfc_expr *
5213 50 : gfc_simplify_lgamma (gfc_expr *x)
5214 : {
5215 50 : gfc_expr *result;
5216 50 : int sg;
5217 :
5218 50 : if (x->expr_type != EXPR_CONSTANT)
5219 : return NULL;
5220 :
5221 42 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5222 42 : mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
5223 :
5224 42 : return range_check (result, "LGAMMA");
5225 : }
5226 :
5227 :
5228 : gfc_expr *
5229 55 : gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
5230 : {
5231 55 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
5232 : return NULL;
5233 :
5234 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
5235 2 : gfc_compare_string (a, b) >= 0);
5236 : }
5237 :
5238 :
5239 : gfc_expr *
5240 81 : gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
5241 : {
5242 81 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
5243 : return NULL;
5244 :
5245 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
5246 2 : gfc_compare_string (a, b) > 0);
5247 : }
5248 :
5249 :
5250 : gfc_expr *
5251 64 : gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
5252 : {
5253 64 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
5254 : return NULL;
5255 :
5256 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
5257 2 : gfc_compare_string (a, b) <= 0);
5258 : }
5259 :
5260 :
5261 : gfc_expr *
5262 72 : gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
5263 : {
5264 72 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
5265 : return NULL;
5266 :
5267 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
5268 2 : gfc_compare_string (a, b) < 0);
5269 : }
5270 :
5271 :
5272 : gfc_expr *
5273 494 : gfc_simplify_log (gfc_expr *x)
5274 : {
5275 494 : gfc_expr *result;
5276 :
5277 494 : if (x->expr_type != EXPR_CONSTANT)
5278 : return NULL;
5279 :
5280 229 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5281 :
5282 229 : switch (x->ts.type)
5283 : {
5284 106 : case BT_REAL:
5285 106 : if (mpfr_sgn (x->value.real) <= 0)
5286 : {
5287 0 : gfc_error ("Argument of LOG at %L cannot be less than or equal "
5288 : "to zero", &x->where);
5289 0 : gfc_free_expr (result);
5290 0 : return &gfc_bad_expr;
5291 : }
5292 :
5293 106 : mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
5294 106 : break;
5295 :
5296 123 : case BT_COMPLEX:
5297 123 : if (mpfr_zero_p (mpc_realref (x->value.complex))
5298 0 : && mpfr_zero_p (mpc_imagref (x->value.complex)))
5299 : {
5300 0 : gfc_error ("Complex argument of LOG at %L cannot be zero",
5301 : &x->where);
5302 0 : gfc_free_expr (result);
5303 0 : return &gfc_bad_expr;
5304 : }
5305 :
5306 123 : gfc_set_model_kind (x->ts.kind);
5307 123 : mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
5308 123 : break;
5309 :
5310 0 : default:
5311 0 : gfc_internal_error ("gfc_simplify_log: bad type");
5312 : }
5313 :
5314 229 : return range_check (result, "LOG");
5315 : }
5316 :
5317 :
5318 : gfc_expr *
5319 328 : gfc_simplify_log10 (gfc_expr *x)
5320 : {
5321 328 : gfc_expr *result;
5322 :
5323 328 : if (x->expr_type != EXPR_CONSTANT)
5324 : return NULL;
5325 :
5326 82 : if (mpfr_sgn (x->value.real) <= 0)
5327 : {
5328 0 : gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
5329 : "to zero", &x->where);
5330 0 : return &gfc_bad_expr;
5331 : }
5332 :
5333 82 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
5334 82 : mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
5335 :
5336 82 : return range_check (result, "LOG10");
5337 : }
5338 :
5339 :
5340 : gfc_expr *
5341 52 : gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
5342 : {
5343 52 : int kind;
5344 :
5345 52 : kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
5346 52 : if (kind < 0)
5347 : return &gfc_bad_expr;
5348 :
5349 52 : if (e->expr_type != EXPR_CONSTANT)
5350 : return NULL;
5351 :
5352 4 : return gfc_get_logical_expr (kind, &e->where, e->value.logical);
5353 : }
5354 :
5355 :
5356 : gfc_expr*
5357 1166 : gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
5358 : {
5359 1166 : gfc_expr *result;
5360 1166 : int row, result_rows, col, result_columns;
5361 1166 : int stride_a, offset_a, stride_b, offset_b;
5362 :
5363 1166 : if (!is_constant_array_expr (matrix_a)
5364 1166 : || !is_constant_array_expr (matrix_b))
5365 : return NULL;
5366 :
5367 : /* MATMUL should do mixed-mode arithmetic. Set the result type. */
5368 63 : if (matrix_a->ts.type != matrix_b->ts.type)
5369 : {
5370 12 : gfc_expr e;
5371 12 : e.expr_type = EXPR_OP;
5372 12 : gfc_clear_ts (&e.ts);
5373 12 : e.value.op.op = INTRINSIC_NONE;
5374 12 : e.value.op.op1 = matrix_a;
5375 12 : e.value.op.op2 = matrix_b;
5376 12 : gfc_type_convert_binary (&e, 1);
5377 12 : result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where);
5378 : }
5379 : else
5380 : {
5381 51 : result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind,
5382 : &matrix_a->where);
5383 : }
5384 :
5385 63 : if (matrix_a->rank == 1 && matrix_b->rank == 2)
5386 : {
5387 7 : result_rows = 1;
5388 7 : result_columns = mpz_get_si (matrix_b->shape[1]);
5389 7 : stride_a = 1;
5390 7 : stride_b = mpz_get_si (matrix_b->shape[0]);
5391 :
5392 7 : result->rank = 1;
5393 7 : result->shape = gfc_get_shape (result->rank);
5394 7 : mpz_init_set_si (result->shape[0], result_columns);
5395 : }
5396 56 : else if (matrix_a->rank == 2 && matrix_b->rank == 1)
5397 : {
5398 6 : result_rows = mpz_get_si (matrix_a->shape[0]);
5399 6 : result_columns = 1;
5400 6 : stride_a = mpz_get_si (matrix_a->shape[0]);
5401 6 : stride_b = 1;
5402 :
5403 6 : result->rank = 1;
5404 6 : result->shape = gfc_get_shape (result->rank);
5405 6 : mpz_init_set_si (result->shape[0], result_rows);
5406 : }
5407 50 : else if (matrix_a->rank == 2 && matrix_b->rank == 2)
5408 : {
5409 50 : result_rows = mpz_get_si (matrix_a->shape[0]);
5410 50 : result_columns = mpz_get_si (matrix_b->shape[1]);
5411 50 : stride_a = mpz_get_si (matrix_a->shape[0]);
5412 50 : stride_b = mpz_get_si (matrix_b->shape[0]);
5413 :
5414 50 : result->rank = 2;
5415 50 : result->shape = gfc_get_shape (result->rank);
5416 50 : mpz_init_set_si (result->shape[0], result_rows);
5417 50 : mpz_init_set_si (result->shape[1], result_columns);
5418 : }
5419 : else
5420 0 : gcc_unreachable();
5421 :
5422 63 : offset_b = 0;
5423 223 : for (col = 0; col < result_columns; ++col)
5424 : {
5425 : offset_a = 0;
5426 :
5427 578 : for (row = 0; row < result_rows; ++row)
5428 : {
5429 418 : gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
5430 : matrix_b, 1, offset_b, false);
5431 418 : gfc_constructor_append_expr (&result->value.constructor,
5432 : e, NULL);
5433 :
5434 418 : offset_a += 1;
5435 : }
5436 :
5437 160 : offset_b += stride_b;
5438 : }
5439 :
5440 : return result;
5441 : }
5442 :
5443 :
5444 : gfc_expr *
5445 285 : gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
5446 : {
5447 285 : gfc_expr *result;
5448 285 : int kind, arg, k;
5449 :
5450 285 : if (i->expr_type != EXPR_CONSTANT)
5451 : return NULL;
5452 :
5453 213 : kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
5454 213 : if (kind == -1)
5455 : return &gfc_bad_expr;
5456 213 : k = gfc_validate_kind (BT_INTEGER, kind, false);
5457 :
5458 213 : bool fail = gfc_extract_int (i, &arg);
5459 213 : gcc_assert (!fail);
5460 :
5461 213 : if (!gfc_check_mask (i, kind_arg))
5462 : return &gfc_bad_expr;
5463 :
5464 211 : result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
5465 :
5466 : /* MASKR(n) = 2^n - 1 */
5467 211 : mpz_set_ui (result->value.integer, 1);
5468 211 : mpz_mul_2exp (result->value.integer, result->value.integer, arg);
5469 211 : mpz_sub_ui (result->value.integer, result->value.integer, 1);
5470 :
5471 211 : gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
5472 :
5473 211 : return result;
5474 : }
5475 :
5476 :
5477 : gfc_expr *
5478 297 : gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
5479 : {
5480 297 : gfc_expr *result;
5481 297 : int kind, arg, k;
5482 297 : mpz_t z;
5483 :
5484 297 : if (i->expr_type != EXPR_CONSTANT)
5485 : return NULL;
5486 :
5487 217 : kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
5488 217 : if (kind == -1)
5489 : return &gfc_bad_expr;
5490 217 : k = gfc_validate_kind (BT_INTEGER, kind, false);
5491 :
5492 217 : bool fail = gfc_extract_int (i, &arg);
5493 217 : gcc_assert (!fail);
5494 :
5495 217 : if (!gfc_check_mask (i, kind_arg))
5496 : return &gfc_bad_expr;
5497 :
5498 213 : result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
5499 :
5500 : /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
5501 213 : mpz_init_set_ui (z, 1);
5502 213 : mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
5503 213 : mpz_set_ui (result->value.integer, 1);
5504 213 : mpz_mul_2exp (result->value.integer, result->value.integer,
5505 213 : gfc_integer_kinds[k].bit_size - arg);
5506 213 : mpz_sub (result->value.integer, z, result->value.integer);
5507 213 : mpz_clear (z);
5508 :
5509 213 : gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
5510 :
5511 213 : return result;
5512 : }
5513 :
5514 : /* Similar to gfc_simplify_maskr, but code paths are different enough to make
5515 : this into a separate function. */
5516 :
5517 : gfc_expr *
5518 24 : gfc_simplify_umaskr (gfc_expr *i, gfc_expr *kind_arg)
5519 : {
5520 24 : gfc_expr *result;
5521 24 : int kind, arg, k;
5522 :
5523 24 : if (i->expr_type != EXPR_CONSTANT)
5524 : return NULL;
5525 :
5526 24 : kind = get_kind (BT_UNSIGNED, kind_arg, "UMASKR", gfc_default_unsigned_kind);
5527 24 : if (kind == -1)
5528 : return &gfc_bad_expr;
5529 24 : k = gfc_validate_kind (BT_UNSIGNED, kind, false);
5530 :
5531 24 : bool fail = gfc_extract_int (i, &arg);
5532 24 : gcc_assert (!fail);
5533 :
5534 24 : if (!gfc_check_mask (i, kind_arg))
5535 : return &gfc_bad_expr;
5536 :
5537 24 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &i->where);
5538 :
5539 : /* MASKR(n) = 2^n - 1 */
5540 24 : mpz_set_ui (result->value.integer, 1);
5541 24 : mpz_mul_2exp (result->value.integer, result->value.integer, arg);
5542 24 : mpz_sub_ui (result->value.integer, result->value.integer, 1);
5543 :
5544 24 : gfc_convert_mpz_to_unsigned (result->value.integer,
5545 : gfc_unsigned_kinds[k].bit_size,
5546 : false);
5547 :
5548 24 : return result;
5549 : }
5550 :
5551 : /* Likewise, similar to gfc_simplify_maskl. */
5552 :
5553 : gfc_expr *
5554 24 : gfc_simplify_umaskl (gfc_expr *i, gfc_expr *kind_arg)
5555 : {
5556 24 : gfc_expr *result;
5557 24 : int kind, arg, k;
5558 24 : mpz_t z;
5559 :
5560 24 : if (i->expr_type != EXPR_CONSTANT)
5561 : return NULL;
5562 :
5563 24 : kind = get_kind (BT_UNSIGNED, kind_arg, "UMASKL", gfc_default_integer_kind);
5564 24 : if (kind == -1)
5565 : return &gfc_bad_expr;
5566 24 : k = gfc_validate_kind (BT_UNSIGNED, kind, false);
5567 :
5568 24 : bool fail = gfc_extract_int (i, &arg);
5569 24 : gcc_assert (!fail);
5570 :
5571 24 : if (!gfc_check_mask (i, kind_arg))
5572 : return &gfc_bad_expr;
5573 :
5574 24 : result = gfc_get_constant_expr (BT_UNSIGNED, kind, &i->where);
5575 :
5576 : /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
5577 24 : mpz_init_set_ui (z, 1);
5578 24 : mpz_mul_2exp (z, z, gfc_unsigned_kinds[k].bit_size);
5579 24 : mpz_set_ui (result->value.integer, 1);
5580 24 : mpz_mul_2exp (result->value.integer, result->value.integer,
5581 24 : gfc_integer_kinds[k].bit_size - arg);
5582 24 : mpz_sub (result->value.integer, z, result->value.integer);
5583 24 : mpz_clear (z);
5584 :
5585 24 : gfc_convert_mpz_to_unsigned (result->value.integer,
5586 : gfc_unsigned_kinds[k].bit_size,
5587 : false);
5588 :
5589 24 : return result;
5590 : }
5591 :
5592 :
5593 : gfc_expr *
5594 4071 : gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
5595 : {
5596 4071 : gfc_expr * result;
5597 4071 : gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
5598 :
5599 4071 : if (mask->expr_type == EXPR_CONSTANT)
5600 : {
5601 : /* The standard requires evaluation of all function arguments.
5602 : Simplify only when the other dropped argument (FSOURCE or TSOURCE)
5603 : is a constant expression. */
5604 699 : if (mask->value.logical)
5605 : {
5606 482 : if (!gfc_is_constant_expr (fsource))
5607 : return NULL;
5608 168 : result = gfc_copy_expr (tsource);
5609 : }
5610 : else
5611 : {
5612 217 : if (!gfc_is_constant_expr (tsource))
5613 : return NULL;
5614 67 : result = gfc_copy_expr (fsource);
5615 : }
5616 :
5617 : /* Parenthesis is needed to get lower bounds of 1. */
5618 235 : result = gfc_get_parentheses (result);
5619 235 : gfc_simplify_expr (result, 1);
5620 235 : return result;
5621 : }
5622 :
5623 761 : if (!mask->rank || !is_constant_array_expr (mask)
5624 3419 : || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
5625 : return NULL;
5626 :
5627 19 : result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
5628 : &tsource->where);
5629 19 : if (tsource->ts.type == BT_DERIVED)
5630 1 : result->ts.u.derived = tsource->ts.u.derived;
5631 18 : else if (tsource->ts.type == BT_CHARACTER)
5632 6 : result->ts.u.cl = tsource->ts.u.cl;
5633 :
5634 19 : tsource_ctor = gfc_constructor_first (tsource->value.constructor);
5635 19 : fsource_ctor = gfc_constructor_first (fsource->value.constructor);
5636 19 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5637 :
5638 87 : while (mask_ctor)
5639 : {
5640 49 : if (mask_ctor->expr->value.logical)
5641 31 : gfc_constructor_append_expr (&result->value.constructor,
5642 : gfc_copy_expr (tsource_ctor->expr),
5643 : NULL);
5644 : else
5645 18 : gfc_constructor_append_expr (&result->value.constructor,
5646 : gfc_copy_expr (fsource_ctor->expr),
5647 : NULL);
5648 49 : tsource_ctor = gfc_constructor_next (tsource_ctor);
5649 49 : fsource_ctor = gfc_constructor_next (fsource_ctor);
5650 49 : mask_ctor = gfc_constructor_next (mask_ctor);
5651 : }
5652 :
5653 19 : result->shape = gfc_get_shape (1);
5654 19 : gfc_array_size (result, &result->shape[0]);
5655 :
5656 19 : return result;
5657 : }
5658 :
5659 :
5660 : gfc_expr *
5661 390 : gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
5662 : {
5663 390 : mpz_t arg1, arg2, mask;
5664 390 : gfc_expr *result;
5665 :
5666 390 : if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
5667 294 : || mask_expr->expr_type != EXPR_CONSTANT)
5668 : return NULL;
5669 :
5670 294 : result = gfc_get_constant_expr (i->ts.type, i->ts.kind, &i->where);
5671 :
5672 : /* Convert all argument to unsigned. */
5673 294 : mpz_init_set (arg1, i->value.integer);
5674 294 : mpz_init_set (arg2, j->value.integer);
5675 294 : mpz_init_set (mask, mask_expr->value.integer);
5676 :
5677 : /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
5678 294 : mpz_and (arg1, arg1, mask);
5679 294 : mpz_com (mask, mask);
5680 294 : mpz_and (arg2, arg2, mask);
5681 294 : mpz_ior (result->value.integer, arg1, arg2);
5682 :
5683 294 : mpz_clear (arg1);
5684 294 : mpz_clear (arg2);
5685 294 : mpz_clear (mask);
5686 :
5687 294 : return result;
5688 : }
5689 :
5690 :
5691 : /* Selects between current value and extremum for simplify_min_max
5692 : and simplify_minval_maxval. */
5693 : static int
5694 3196 : min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
5695 : {
5696 3196 : int ret;
5697 :
5698 3196 : switch (arg->ts.type)
5699 : {
5700 2101 : case BT_INTEGER:
5701 2101 : case BT_UNSIGNED:
5702 2101 : if (extremum->ts.kind < arg->ts.kind)
5703 1 : extremum->ts.kind = arg->ts.kind;
5704 2101 : ret = mpz_cmp (arg->value.integer,
5705 2101 : extremum->value.integer) * sign;
5706 2101 : if (ret > 0)
5707 1278 : mpz_set (extremum->value.integer, arg->value.integer);
5708 : break;
5709 :
5710 598 : case BT_REAL:
5711 598 : if (extremum->ts.kind < arg->ts.kind)
5712 25 : extremum->ts.kind = arg->ts.kind;
5713 598 : if (mpfr_nan_p (extremum->value.real))
5714 : {
5715 192 : ret = 1;
5716 192 : mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
5717 : }
5718 406 : else if (mpfr_nan_p (arg->value.real))
5719 : ret = -1;
5720 : else
5721 : {
5722 286 : ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign;
5723 286 : if (ret > 0)
5724 140 : mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
5725 : }
5726 : break;
5727 :
5728 497 : case BT_CHARACTER:
5729 : #define LENGTH(x) ((x)->value.character.length)
5730 : #define STRING(x) ((x)->value.character.string)
5731 497 : if (LENGTH (extremum) < LENGTH(arg))
5732 : {
5733 12 : gfc_char_t *tmp = STRING(extremum);
5734 :
5735 12 : STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
5736 12 : memcpy (STRING(extremum), tmp,
5737 12 : LENGTH(extremum) * sizeof (gfc_char_t));
5738 12 : gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
5739 12 : LENGTH(arg) - LENGTH(extremum));
5740 12 : STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
5741 12 : LENGTH(extremum) = LENGTH(arg);
5742 12 : free (tmp);
5743 : }
5744 497 : ret = gfc_compare_string (arg, extremum) * sign;
5745 497 : if (ret > 0)
5746 : {
5747 187 : free (STRING(extremum));
5748 187 : STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
5749 187 : memcpy (STRING(extremum), STRING(arg),
5750 187 : LENGTH(arg) * sizeof (gfc_char_t));
5751 187 : gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
5752 187 : LENGTH(extremum) - LENGTH(arg));
5753 187 : STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
5754 : }
5755 : #undef LENGTH
5756 : #undef STRING
5757 : break;
5758 :
5759 0 : default:
5760 0 : gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5761 : }
5762 3196 : if (back_val && ret == 0)
5763 59 : ret = 1;
5764 :
5765 3196 : return ret;
5766 : }
5767 :
5768 :
5769 : /* This function is special since MAX() can take any number of
5770 : arguments. The simplified expression is a rewritten version of the
5771 : argument list containing at most one constant element. Other
5772 : constant elements are deleted. Because the argument list has
5773 : already been checked, this function always succeeds. sign is 1 for
5774 : MAX(), -1 for MIN(). */
5775 :
5776 : static gfc_expr *
5777 6124 : simplify_min_max (gfc_expr *expr, int sign)
5778 : {
5779 6124 : int tmp1, tmp2;
5780 6124 : gfc_actual_arglist *arg, *last, *extremum;
5781 6124 : gfc_expr *tmp, *ret;
5782 6124 : const char *fname;
5783 :
5784 6124 : last = NULL;
5785 6124 : extremum = NULL;
5786 :
5787 6124 : arg = expr->value.function.actual;
5788 :
5789 19648 : for (; arg; last = arg, arg = arg->next)
5790 : {
5791 13524 : if (arg->expr->expr_type != EXPR_CONSTANT)
5792 7967 : continue;
5793 :
5794 5557 : if (extremum == NULL)
5795 : {
5796 3492 : extremum = arg;
5797 3492 : continue;
5798 : }
5799 :
5800 2065 : min_max_choose (arg->expr, extremum->expr, sign);
5801 :
5802 : /* Delete the extra constant argument. */
5803 2065 : last->next = arg->next;
5804 :
5805 2065 : arg->next = NULL;
5806 2065 : gfc_free_actual_arglist (arg);
5807 2065 : arg = last;
5808 : }
5809 :
5810 : /* If there is one value left, replace the function call with the
5811 : expression. */
5812 6124 : if (expr->value.function.actual->next != NULL)
5813 : return NULL;
5814 :
5815 : /* Handle special cases of specific functions (min|max)1 and
5816 : a(min|max)0. */
5817 :
5818 1684 : tmp = expr->value.function.actual->expr;
5819 1684 : fname = expr->value.function.isym->name;
5820 :
5821 1684 : if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind)
5822 582 : && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0))
5823 : {
5824 : /* Explicit conversion, turn off -Wconversion and -Wconversion-extra
5825 : warnings. */
5826 15 : tmp1 = warn_conversion;
5827 15 : tmp2 = warn_conversion_extra;
5828 15 : warn_conversion = warn_conversion_extra = 0;
5829 :
5830 15 : ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind);
5831 :
5832 15 : warn_conversion = tmp1;
5833 15 : warn_conversion_extra = tmp2;
5834 : }
5835 1669 : else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind)
5836 1452 : && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0))
5837 : {
5838 15 : ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind);
5839 : }
5840 : else
5841 1654 : ret = gfc_copy_expr (tmp);
5842 :
5843 : return ret;
5844 :
5845 : }
5846 :
5847 :
5848 : gfc_expr *
5849 1989 : gfc_simplify_min (gfc_expr *e)
5850 : {
5851 1989 : return simplify_min_max (e, -1);
5852 : }
5853 :
5854 :
5855 : gfc_expr *
5856 4135 : gfc_simplify_max (gfc_expr *e)
5857 : {
5858 4135 : return simplify_min_max (e, 1);
5859 : }
5860 :
5861 : /* Helper function for gfc_simplify_minval. */
5862 :
5863 : static gfc_expr *
5864 295 : gfc_min (gfc_expr *op1, gfc_expr *op2)
5865 : {
5866 295 : min_max_choose (op1, op2, -1);
5867 295 : gfc_free_expr (op1);
5868 295 : return op2;
5869 : }
5870 :
5871 : /* Simplify minval for constant arrays. */
5872 :
5873 : gfc_expr *
5874 3981 : gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5875 : {
5876 3981 : return simplify_transformation (array, dim, mask, INT_MAX, gfc_min);
5877 : }
5878 :
5879 : /* Helper function for gfc_simplify_maxval. */
5880 :
5881 : static gfc_expr *
5882 271 : gfc_max (gfc_expr *op1, gfc_expr *op2)
5883 : {
5884 271 : min_max_choose (op1, op2, 1);
5885 271 : gfc_free_expr (op1);
5886 271 : return op2;
5887 : }
5888 :
5889 :
5890 : /* Simplify maxval for constant arrays. */
5891 :
5892 : gfc_expr *
5893 3013 : gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5894 : {
5895 3013 : return simplify_transformation (array, dim, mask, INT_MIN, gfc_max);
5896 : }
5897 :
5898 :
5899 : /* Transform minloc or maxloc of an array, according to MASK,
5900 : to the scalar result. This code is mostly identical to
5901 : simplify_transformation_to_scalar. */
5902 :
5903 : static gfc_expr *
5904 82 : simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
5905 : gfc_expr *extremum, int sign, bool back_val)
5906 : {
5907 82 : gfc_expr *a, *m;
5908 82 : gfc_constructor *array_ctor, *mask_ctor;
5909 82 : mpz_t count;
5910 :
5911 82 : mpz_set_si (result->value.integer, 0);
5912 :
5913 :
5914 : /* Shortcut for constant .FALSE. MASK. */
5915 82 : if (mask
5916 42 : && mask->expr_type == EXPR_CONSTANT
5917 36 : && !mask->value.logical)
5918 : return result;
5919 :
5920 46 : array_ctor = gfc_constructor_first (array->value.constructor);
5921 46 : if (mask && mask->expr_type == EXPR_ARRAY)
5922 6 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5923 : else
5924 : mask_ctor = NULL;
5925 :
5926 46 : mpz_init_set_si (count, 0);
5927 216 : while (array_ctor)
5928 : {
5929 124 : mpz_add_ui (count, count, 1);
5930 124 : a = array_ctor->expr;
5931 124 : array_ctor = gfc_constructor_next (array_ctor);
5932 : /* A constant MASK equals .TRUE. here and can be ignored. */
5933 124 : if (mask_ctor)
5934 : {
5935 28 : m = mask_ctor->expr;
5936 28 : mask_ctor = gfc_constructor_next (mask_ctor);
5937 28 : if (!m->value.logical)
5938 12 : continue;
5939 : }
5940 112 : if (min_max_choose (a, extremum, sign, back_val) > 0)
5941 60 : mpz_set (result->value.integer, count);
5942 : }
5943 46 : mpz_clear (count);
5944 46 : gfc_free_expr (extremum);
5945 46 : return result;
5946 : }
5947 :
5948 : /* Simplify minloc / maxloc in the absence of a dim argument. */
5949 :
5950 : static gfc_expr *
5951 69 : simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
5952 : gfc_expr *array, gfc_expr *mask, int sign,
5953 : bool back_val)
5954 : {
5955 69 : ssize_t res[GFC_MAX_DIMENSIONS];
5956 69 : int i, n;
5957 69 : gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5958 69 : ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5959 : sstride[GFC_MAX_DIMENSIONS];
5960 69 : gfc_expr *a, *m;
5961 69 : bool continue_loop;
5962 69 : bool ma;
5963 :
5964 154 : for (i = 0; i<array->rank; i++)
5965 85 : res[i] = -1;
5966 :
5967 : /* Shortcut for constant .FALSE. MASK. */
5968 69 : if (mask
5969 56 : && mask->expr_type == EXPR_CONSTANT
5970 40 : && !mask->value.logical)
5971 38 : goto finish;
5972 :
5973 31 : if (array->shape == NULL)
5974 1 : goto finish;
5975 :
5976 66 : for (i = 0; i < array->rank; i++)
5977 : {
5978 44 : count[i] = 0;
5979 44 : sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5980 44 : extent[i] = mpz_get_si (array->shape[i]);
5981 44 : if (extent[i] <= 0)
5982 8 : goto finish;
5983 : }
5984 :
5985 22 : continue_loop = true;
5986 22 : array_ctor = gfc_constructor_first (array->value.constructor);
5987 22 : if (mask && mask->rank > 0)
5988 12 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5989 : else
5990 22 : mask_ctor = NULL;
5991 :
5992 : /* Loop over the array elements (and mask), keeping track of
5993 : the indices to return. */
5994 66 : while (continue_loop)
5995 : {
5996 120 : do
5997 : {
5998 120 : a = array_ctor->expr;
5999 120 : if (mask_ctor)
6000 : {
6001 46 : m = mask_ctor->expr;
6002 46 : ma = m->value.logical;
6003 46 : mask_ctor = gfc_constructor_next (mask_ctor);
6004 : }
6005 : else
6006 : ma = true;
6007 :
6008 120 : if (ma && min_max_choose (a, extremum, sign, back_val) > 0)
6009 : {
6010 130 : for (i = 0; i<array->rank; i++)
6011 86 : res[i] = count[i];
6012 : }
6013 120 : array_ctor = gfc_constructor_next (array_ctor);
6014 120 : count[0] ++;
6015 120 : } while (count[0] != extent[0]);
6016 : n = 0;
6017 58 : do
6018 : {
6019 : /* When we get to the end of a dimension, reset it and increment
6020 : the next dimension. */
6021 58 : count[n] = 0;
6022 58 : n++;
6023 58 : if (n >= array->rank)
6024 : {
6025 : continue_loop = false;
6026 : break;
6027 : }
6028 : else
6029 36 : count[n] ++;
6030 36 : } while (count[n] == extent[n]);
6031 : }
6032 :
6033 22 : finish:
6034 69 : gfc_free_expr (extremum);
6035 69 : result_ctor = gfc_constructor_first (result->value.constructor);
6036 223 : for (i = 0; i<array->rank; i++)
6037 : {
6038 85 : gfc_expr *r_expr;
6039 85 : r_expr = result_ctor->expr;
6040 85 : mpz_set_si (r_expr->value.integer, res[i] + 1);
6041 85 : result_ctor = gfc_constructor_next (result_ctor);
6042 : }
6043 69 : return result;
6044 : }
6045 :
6046 : /* Helper function for gfc_simplify_minmaxloc - build an array
6047 : expression with n elements. */
6048 :
6049 : static gfc_expr *
6050 116 : new_array (bt type, int kind, int n, locus *where)
6051 : {
6052 116 : gfc_expr *result;
6053 116 : int i;
6054 :
6055 116 : result = gfc_get_array_expr (type, kind, where);
6056 116 : result->rank = 1;
6057 116 : result->shape = gfc_get_shape(1);
6058 116 : mpz_init_set_si (result->shape[0], n);
6059 401 : for (i = 0; i < n; i++)
6060 : {
6061 169 : gfc_constructor_append_expr (&result->value.constructor,
6062 : gfc_get_constant_expr (type, kind, where),
6063 : NULL);
6064 : }
6065 :
6066 116 : return result;
6067 : }
6068 :
6069 : /* Simplify minloc and maxloc. This code is mostly identical to
6070 : simplify_transformation_to_array. */
6071 :
6072 : static gfc_expr *
6073 48 : simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
6074 : gfc_expr *dim, gfc_expr *mask,
6075 : gfc_expr *extremum, int sign, bool back_val)
6076 : {
6077 48 : mpz_t size;
6078 48 : int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
6079 48 : gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
6080 48 : gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
6081 :
6082 48 : int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
6083 : sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
6084 : tmpstride[GFC_MAX_DIMENSIONS];
6085 :
6086 : /* Shortcut for constant .FALSE. MASK. */
6087 48 : if (mask
6088 10 : && mask->expr_type == EXPR_CONSTANT
6089 0 : && !mask->value.logical)
6090 : return result;
6091 :
6092 : /* Build an indexed table for array element expressions to minimize
6093 : linked-list traversal. Masked elements are set to NULL. */
6094 48 : gfc_array_size (array, &size);
6095 48 : arraysize = mpz_get_ui (size);
6096 48 : mpz_clear (size);
6097 :
6098 48 : arrayvec = XCNEWVEC (gfc_expr*, arraysize);
6099 :
6100 48 : array_ctor = gfc_constructor_first (array->value.constructor);
6101 48 : mask_ctor = NULL;
6102 48 : if (mask && mask->expr_type == EXPR_ARRAY)
6103 10 : mask_ctor = gfc_constructor_first (mask->value.constructor);
6104 :
6105 474 : for (i = 0; i < arraysize; ++i)
6106 : {
6107 426 : arrayvec[i] = array_ctor->expr;
6108 426 : array_ctor = gfc_constructor_next (array_ctor);
6109 :
6110 426 : if (mask_ctor)
6111 : {
6112 106 : if (!mask_ctor->expr->value.logical)
6113 65 : arrayvec[i] = NULL;
6114 :
6115 106 : mask_ctor = gfc_constructor_next (mask_ctor);
6116 : }
6117 : }
6118 :
6119 : /* Same for the result expression. */
6120 48 : gfc_array_size (result, &size);
6121 48 : resultsize = mpz_get_ui (size);
6122 48 : mpz_clear (size);
6123 :
6124 48 : resultvec = XCNEWVEC (gfc_expr*, resultsize);
6125 48 : result_ctor = gfc_constructor_first (result->value.constructor);
6126 234 : for (i = 0; i < resultsize; ++i)
6127 : {
6128 138 : resultvec[i] = result_ctor->expr;
6129 138 : result_ctor = gfc_constructor_next (result_ctor);
6130 : }
6131 :
6132 48 : gfc_extract_int (dim, &dim_index);
6133 48 : dim_index -= 1; /* zero-base index */
6134 48 : dim_extent = 0;
6135 48 : dim_stride = 0;
6136 :
6137 144 : for (i = 0, n = 0; i < array->rank; ++i)
6138 : {
6139 96 : count[i] = 0;
6140 96 : tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
6141 96 : if (i == dim_index)
6142 : {
6143 48 : dim_extent = mpz_get_si (array->shape[i]);
6144 48 : dim_stride = tmpstride[i];
6145 48 : continue;
6146 : }
6147 :
6148 48 : extent[n] = mpz_get_si (array->shape[i]);
6149 48 : sstride[n] = tmpstride[i];
6150 48 : dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
6151 48 : n += 1;
6152 : }
6153 :
6154 48 : done = resultsize <= 0;
6155 48 : base = arrayvec;
6156 48 : dest = resultvec;
6157 234 : while (!done)
6158 : {
6159 138 : gfc_expr *ex;
6160 138 : ex = gfc_copy_expr (extremum);
6161 702 : for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
6162 : {
6163 426 : if (*src && min_max_choose (*src, ex, sign, back_val) > 0)
6164 215 : mpz_set_si ((*dest)->value.integer, n + 1);
6165 : }
6166 :
6167 138 : count[0]++;
6168 138 : base += sstride[0];
6169 138 : dest += dstride[0];
6170 138 : gfc_free_expr (ex);
6171 :
6172 138 : n = 0;
6173 276 : while (!done && count[n] == extent[n])
6174 : {
6175 46 : count[n] = 0;
6176 46 : base -= sstride[n] * extent[n];
6177 46 : dest -= dstride[n] * extent[n];
6178 :
6179 46 : n++;
6180 46 : if (n < result->rank)
6181 : {
6182 : /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
6183 : times, we'd warn for the last iteration, because the
6184 : array index will have already been incremented to the
6185 : array sizes, and we can't tell that this must make
6186 : the test against result->rank false, because ranks
6187 : must not exceed GFC_MAX_DIMENSIONS. */
6188 0 : GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
6189 0 : count[n]++;
6190 0 : base += sstride[n];
6191 0 : dest += dstride[n];
6192 0 : GCC_DIAGNOSTIC_POP
6193 : }
6194 : else
6195 : done = true;
6196 : }
6197 : }
6198 :
6199 : /* Place updated expression in result constructor. */
6200 48 : result_ctor = gfc_constructor_first (result->value.constructor);
6201 234 : for (i = 0; i < resultsize; ++i)
6202 : {
6203 138 : result_ctor->expr = resultvec[i];
6204 138 : result_ctor = gfc_constructor_next (result_ctor);
6205 : }
6206 :
6207 48 : free (arrayvec);
6208 48 : free (resultvec);
6209 48 : free (extremum);
6210 48 : return result;
6211 : }
6212 :
6213 : /* Simplify minloc and maxloc for constant arrays. */
6214 :
6215 : static gfc_expr *
6216 20917 : gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
6217 : gfc_expr *kind, gfc_expr *back, int sign)
6218 : {
6219 20917 : gfc_expr *result;
6220 20917 : gfc_expr *extremum;
6221 20917 : int ikind;
6222 20917 : int init_val;
6223 20917 : bool back_val = false;
6224 :
6225 20917 : if (!is_constant_array_expr (array)
6226 20917 : || !gfc_is_constant_expr (dim))
6227 : return NULL;
6228 :
6229 307 : if (mask
6230 216 : && !is_constant_array_expr (mask)
6231 491 : && mask->expr_type != EXPR_CONSTANT)
6232 : return NULL;
6233 :
6234 199 : if (kind)
6235 : {
6236 0 : if (gfc_extract_int (kind, &ikind, -1))
6237 : return NULL;
6238 : }
6239 : else
6240 199 : ikind = gfc_default_integer_kind;
6241 :
6242 199 : if (back)
6243 : {
6244 199 : if (back->expr_type != EXPR_CONSTANT)
6245 : return NULL;
6246 :
6247 199 : back_val = back->value.logical;
6248 : }
6249 :
6250 199 : if (sign < 0)
6251 : init_val = INT_MAX;
6252 101 : else if (sign > 0)
6253 : init_val = INT_MIN;
6254 : else
6255 0 : gcc_unreachable();
6256 :
6257 199 : extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
6258 199 : init_result_expr (extremum, init_val, array);
6259 :
6260 199 : if (dim)
6261 : {
6262 130 : result = transformational_result (array, dim, BT_INTEGER,
6263 : ikind, &array->where);
6264 130 : init_result_expr (result, 0, array);
6265 :
6266 130 : if (array->rank == 1)
6267 82 : return simplify_minmaxloc_to_scalar (result, array, mask, extremum,
6268 82 : sign, back_val);
6269 : else
6270 48 : return simplify_minmaxloc_to_array (result, array, dim, mask, extremum,
6271 48 : sign, back_val);
6272 : }
6273 : else
6274 : {
6275 69 : result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
6276 69 : return simplify_minmaxloc_nodim (result, extremum, array, mask,
6277 69 : sign, back_val);
6278 : }
6279 : }
6280 :
6281 : gfc_expr *
6282 11240 : gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
6283 : gfc_expr *back)
6284 : {
6285 11240 : return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1);
6286 : }
6287 :
6288 : gfc_expr *
6289 9677 : gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
6290 : gfc_expr *back)
6291 : {
6292 9677 : return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
6293 : }
6294 :
6295 : /* Simplify findloc to scalar. Similar to
6296 : simplify_minmaxloc_to_scalar. */
6297 :
6298 : static gfc_expr *
6299 50 : simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
6300 : gfc_expr *mask, int back_val)
6301 : {
6302 50 : gfc_expr *a, *m;
6303 50 : gfc_constructor *array_ctor, *mask_ctor;
6304 50 : mpz_t count;
6305 :
6306 50 : mpz_set_si (result->value.integer, 0);
6307 :
6308 : /* Shortcut for constant .FALSE. MASK. */
6309 50 : if (mask
6310 14 : && mask->expr_type == EXPR_CONSTANT
6311 0 : && !mask->value.logical)
6312 : return result;
6313 :
6314 50 : array_ctor = gfc_constructor_first (array->value.constructor);
6315 50 : if (mask && mask->expr_type == EXPR_ARRAY)
6316 14 : mask_ctor = gfc_constructor_first (mask->value.constructor);
6317 : else
6318 : mask_ctor = NULL;
6319 :
6320 50 : mpz_init_set_si (count, 0);
6321 227 : while (array_ctor)
6322 : {
6323 156 : mpz_add_ui (count, count, 1);
6324 156 : a = array_ctor->expr;
6325 156 : array_ctor = gfc_constructor_next (array_ctor);
6326 : /* A constant MASK equals .TRUE. here and can be ignored. */
6327 156 : if (mask_ctor)
6328 : {
6329 56 : m = mask_ctor->expr;
6330 56 : mask_ctor = gfc_constructor_next (mask_ctor);
6331 56 : if (!m->value.logical)
6332 14 : continue;
6333 : }
6334 142 : if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
6335 : {
6336 : /* We have a match. If BACK is true, continue so we find
6337 : the last one. */
6338 50 : mpz_set (result->value.integer, count);
6339 50 : if (!back_val)
6340 : break;
6341 : }
6342 : }
6343 50 : mpz_clear (count);
6344 50 : return result;
6345 : }
6346 :
6347 : /* Simplify findloc in the absence of a dim argument. Similar to
6348 : simplify_minmaxloc_nodim. */
6349 :
6350 : static gfc_expr *
6351 47 : simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
6352 : gfc_expr *mask, bool back_val)
6353 : {
6354 47 : ssize_t res[GFC_MAX_DIMENSIONS];
6355 47 : int i, n;
6356 47 : gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
6357 47 : ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
6358 : sstride[GFC_MAX_DIMENSIONS];
6359 47 : gfc_expr *a, *m;
6360 47 : bool continue_loop;
6361 47 : bool ma;
6362 :
6363 131 : for (i = 0; i < array->rank; i++)
6364 84 : res[i] = -1;
6365 :
6366 : /* Shortcut for constant .FALSE. MASK. */
6367 47 : if (mask
6368 7 : && mask->expr_type == EXPR_CONSTANT
6369 0 : && !mask->value.logical)
6370 0 : goto finish;
6371 :
6372 125 : for (i = 0; i < array->rank; i++)
6373 : {
6374 84 : count[i] = 0;
6375 84 : sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
6376 84 : extent[i] = mpz_get_si (array->shape[i]);
6377 84 : if (extent[i] <= 0)
6378 6 : goto finish;
6379 : }
6380 :
6381 41 : continue_loop = true;
6382 41 : array_ctor = gfc_constructor_first (array->value.constructor);
6383 41 : if (mask && mask->rank > 0)
6384 7 : mask_ctor = gfc_constructor_first (mask->value.constructor);
6385 : else
6386 41 : mask_ctor = NULL;
6387 :
6388 : /* Loop over the array elements (and mask), keeping track of
6389 : the indices to return. */
6390 93 : while (continue_loop)
6391 : {
6392 138 : do
6393 : {
6394 138 : a = array_ctor->expr;
6395 138 : if (mask_ctor)
6396 : {
6397 28 : m = mask_ctor->expr;
6398 28 : ma = m->value.logical;
6399 28 : mask_ctor = gfc_constructor_next (mask_ctor);
6400 : }
6401 : else
6402 : ma = true;
6403 :
6404 138 : if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
6405 : {
6406 73 : for (i = 0; i < array->rank; i++)
6407 48 : res[i] = count[i];
6408 25 : if (!back_val)
6409 17 : goto finish;
6410 : }
6411 121 : array_ctor = gfc_constructor_next (array_ctor);
6412 121 : count[0] ++;
6413 121 : } while (count[0] != extent[0]);
6414 : n = 0;
6415 73 : do
6416 : {
6417 : /* When we get to the end of a dimension, reset it and increment
6418 : the next dimension. */
6419 73 : count[n] = 0;
6420 73 : n++;
6421 73 : if (n >= array->rank)
6422 : {
6423 : continue_loop = false;
6424 : break;
6425 : }
6426 : else
6427 49 : count[n] ++;
6428 49 : } while (count[n] == extent[n]);
6429 : }
6430 :
6431 24 : finish:
6432 47 : result_ctor = gfc_constructor_first (result->value.constructor);
6433 178 : for (i = 0; i < array->rank; i++)
6434 : {
6435 84 : gfc_expr *r_expr;
6436 84 : r_expr = result_ctor->expr;
6437 84 : mpz_set_si (r_expr->value.integer, res[i] + 1);
6438 84 : result_ctor = gfc_constructor_next (result_ctor);
6439 : }
6440 47 : return result;
6441 : }
6442 :
6443 :
6444 : /* Simplify findloc to an array. Similar to
6445 : simplify_minmaxloc_to_array. */
6446 :
6447 : static gfc_expr *
6448 14 : simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
6449 : gfc_expr *dim, gfc_expr *mask, bool back_val)
6450 : {
6451 14 : mpz_t size;
6452 14 : int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
6453 14 : gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
6454 14 : gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
6455 :
6456 14 : int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
6457 : sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
6458 : tmpstride[GFC_MAX_DIMENSIONS];
6459 :
6460 : /* Shortcut for constant .FALSE. MASK. */
6461 14 : if (mask
6462 0 : && mask->expr_type == EXPR_CONSTANT
6463 0 : && !mask->value.logical)
6464 : return result;
6465 :
6466 : /* Build an indexed table for array element expressions to minimize
6467 : linked-list traversal. Masked elements are set to NULL. */
6468 14 : gfc_array_size (array, &size);
6469 14 : arraysize = mpz_get_ui (size);
6470 14 : mpz_clear (size);
6471 :
6472 14 : arrayvec = XCNEWVEC (gfc_expr*, arraysize);
6473 :
6474 14 : array_ctor = gfc_constructor_first (array->value.constructor);
6475 14 : mask_ctor = NULL;
6476 14 : if (mask && mask->expr_type == EXPR_ARRAY)
6477 0 : mask_ctor = gfc_constructor_first (mask->value.constructor);
6478 :
6479 98 : for (i = 0; i < arraysize; ++i)
6480 : {
6481 84 : arrayvec[i] = array_ctor->expr;
6482 84 : array_ctor = gfc_constructor_next (array_ctor);
6483 :
6484 84 : if (mask_ctor)
6485 : {
6486 0 : if (!mask_ctor->expr->value.logical)
6487 0 : arrayvec[i] = NULL;
6488 :
6489 0 : mask_ctor = gfc_constructor_next (mask_ctor);
6490 : }
6491 : }
6492 :
6493 : /* Same for the result expression. */
6494 14 : gfc_array_size (result, &size);
6495 14 : resultsize = mpz_get_ui (size);
6496 14 : mpz_clear (size);
6497 :
6498 14 : resultvec = XCNEWVEC (gfc_expr*, resultsize);
6499 14 : result_ctor = gfc_constructor_first (result->value.constructor);
6500 63 : for (i = 0; i < resultsize; ++i)
6501 : {
6502 35 : resultvec[i] = result_ctor->expr;
6503 35 : result_ctor = gfc_constructor_next (result_ctor);
6504 : }
6505 :
6506 14 : gfc_extract_int (dim, &dim_index);
6507 :
6508 14 : dim_index -= 1; /* Zero-base index. */
6509 14 : dim_extent = 0;
6510 14 : dim_stride = 0;
6511 :
6512 42 : for (i = 0, n = 0; i < array->rank; ++i)
6513 : {
6514 28 : count[i] = 0;
6515 28 : tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
6516 28 : if (i == dim_index)
6517 : {
6518 14 : dim_extent = mpz_get_si (array->shape[i]);
6519 14 : dim_stride = tmpstride[i];
6520 14 : continue;
6521 : }
6522 :
6523 14 : extent[n] = mpz_get_si (array->shape[i]);
6524 14 : sstride[n] = tmpstride[i];
6525 14 : dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
6526 14 : n += 1;
6527 : }
6528 :
6529 14 : done = resultsize <= 0;
6530 14 : base = arrayvec;
6531 14 : dest = resultvec;
6532 63 : while (!done)
6533 : {
6534 63 : for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
6535 : {
6536 56 : if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
6537 : {
6538 28 : mpz_set_si ((*dest)->value.integer, n + 1);
6539 28 : if (!back_val)
6540 : break;
6541 : }
6542 : }
6543 :
6544 35 : count[0]++;
6545 35 : base += sstride[0];
6546 35 : dest += dstride[0];
6547 :
6548 35 : n = 0;
6549 35 : while (!done && count[n] == extent[n])
6550 : {
6551 14 : count[n] = 0;
6552 14 : base -= sstride[n] * extent[n];
6553 14 : dest -= dstride[n] * extent[n];
6554 :
6555 14 : n++;
6556 14 : if (n < result->rank)
6557 : {
6558 : /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
6559 : times, we'd warn for the last iteration, because the
6560 : array index will have already been incremented to the
6561 : array sizes, and we can't tell that this must make
6562 : the test against result->rank false, because ranks
6563 : must not exceed GFC_MAX_DIMENSIONS. */
6564 0 : GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
6565 0 : count[n]++;
6566 0 : base += sstride[n];
6567 0 : dest += dstride[n];
6568 0 : GCC_DIAGNOSTIC_POP
6569 : }
6570 : else
6571 : done = true;
6572 : }
6573 : }
6574 :
6575 : /* Place updated expression in result constructor. */
6576 14 : result_ctor = gfc_constructor_first (result->value.constructor);
6577 63 : for (i = 0; i < resultsize; ++i)
6578 : {
6579 35 : result_ctor->expr = resultvec[i];
6580 35 : result_ctor = gfc_constructor_next (result_ctor);
6581 : }
6582 :
6583 14 : free (arrayvec);
6584 14 : free (resultvec);
6585 14 : return result;
6586 : }
6587 :
6588 : /* Simplify findloc. */
6589 :
6590 : gfc_expr *
6591 1380 : gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
6592 : gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
6593 : {
6594 1380 : gfc_expr *result;
6595 1380 : int ikind;
6596 1380 : bool back_val = false;
6597 :
6598 1380 : if (!is_constant_array_expr (array)
6599 114 : || array->shape == NULL
6600 1493 : || !gfc_is_constant_expr (dim))
6601 : return NULL;
6602 :
6603 113 : if (! gfc_is_constant_expr (value))
6604 : return 0;
6605 :
6606 113 : if (mask
6607 21 : && !is_constant_array_expr (mask)
6608 113 : && mask->expr_type != EXPR_CONSTANT)
6609 : return NULL;
6610 :
6611 113 : if (kind)
6612 : {
6613 0 : if (gfc_extract_int (kind, &ikind, -1))
6614 : return NULL;
6615 : }
6616 : else
6617 113 : ikind = gfc_default_integer_kind;
6618 :
6619 113 : if (back)
6620 : {
6621 113 : if (back->expr_type != EXPR_CONSTANT)
6622 : return NULL;
6623 :
6624 111 : back_val = back->value.logical;
6625 : }
6626 :
6627 111 : if (dim)
6628 : {
6629 64 : result = transformational_result (array, dim, BT_INTEGER,
6630 : ikind, &array->where);
6631 64 : init_result_expr (result, 0, array);
6632 :
6633 64 : if (array->rank == 1)
6634 50 : return simplify_findloc_to_scalar (result, array, value, mask,
6635 50 : back_val);
6636 : else
6637 14 : return simplify_findloc_to_array (result, array, value, dim, mask,
6638 14 : back_val);
6639 : }
6640 : else
6641 : {
6642 47 : result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
6643 47 : return simplify_findloc_nodim (result, value, array, mask, back_val);
6644 : }
6645 : return NULL;
6646 : }
6647 :
6648 : gfc_expr *
6649 1 : gfc_simplify_maxexponent (gfc_expr *x)
6650 : {
6651 1 : int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6652 1 : return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
6653 1 : gfc_real_kinds[i].max_exponent);
6654 : }
6655 :
6656 :
6657 : gfc_expr *
6658 25 : gfc_simplify_minexponent (gfc_expr *x)
6659 : {
6660 25 : int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6661 25 : return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
6662 25 : gfc_real_kinds[i].min_exponent);
6663 : }
6664 :
6665 :
6666 : gfc_expr *
6667 267176 : gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
6668 : {
6669 267176 : gfc_expr *result;
6670 267176 : int kind;
6671 :
6672 : /* First check p. */
6673 267176 : if (p->expr_type != EXPR_CONSTANT)
6674 : return NULL;
6675 :
6676 : /* p shall not be 0. */
6677 266311 : switch (p->ts.type)
6678 : {
6679 266203 : case BT_INTEGER:
6680 266203 : case BT_UNSIGNED:
6681 266203 : if (mpz_cmp_ui (p->value.integer, 0) == 0)
6682 : {
6683 4 : gfc_error ("Argument %qs of MOD at %L shall not be zero",
6684 : "P", &p->where);
6685 4 : return &gfc_bad_expr;
6686 : }
6687 : break;
6688 108 : case BT_REAL:
6689 108 : if (mpfr_cmp_ui (p->value.real, 0) == 0)
6690 : {
6691 0 : gfc_error ("Argument %qs of MOD at %L shall not be zero",
6692 : "P", &p->where);
6693 0 : return &gfc_bad_expr;
6694 : }
6695 : break;
6696 0 : default:
6697 0 : gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6698 : }
6699 :
6700 266307 : if (a->expr_type != EXPR_CONSTANT)
6701 : return NULL;
6702 :
6703 262824 : kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6704 262824 : result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6705 :
6706 262824 : if (a->ts.type == BT_INTEGER || a->ts.type == BT_UNSIGNED)
6707 262716 : mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
6708 : else
6709 : {
6710 108 : gfc_set_model_kind (kind);
6711 108 : mpfr_fmod (result->value.real, a->value.real, p->value.real,
6712 : GFC_RND_MODE);
6713 : }
6714 :
6715 262824 : return range_check (result, "MOD");
6716 : }
6717 :
6718 :
6719 : gfc_expr *
6720 1941 : gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
6721 : {
6722 1941 : gfc_expr *result;
6723 1941 : int kind;
6724 :
6725 : /* First check p. */
6726 1941 : if (p->expr_type != EXPR_CONSTANT)
6727 : return NULL;
6728 :
6729 : /* p shall not be 0. */
6730 1744 : switch (p->ts.type)
6731 : {
6732 1708 : case BT_INTEGER:
6733 1708 : case BT_UNSIGNED:
6734 1708 : if (mpz_cmp_ui (p->value.integer, 0) == 0)
6735 : {
6736 4 : gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6737 : "P", &p->where);
6738 4 : return &gfc_bad_expr;
6739 : }
6740 : break;
6741 36 : case BT_REAL:
6742 36 : if (mpfr_cmp_ui (p->value.real, 0) == 0)
6743 : {
6744 0 : gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6745 : "P", &p->where);
6746 0 : return &gfc_bad_expr;
6747 : }
6748 : break;
6749 0 : default:
6750 0 : gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6751 : }
6752 :
6753 1740 : if (a->expr_type != EXPR_CONSTANT)
6754 : return NULL;
6755 :
6756 253 : kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6757 253 : result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6758 :
6759 253 : if (a->ts.type == BT_INTEGER || a->ts.type == BT_UNSIGNED)
6760 217 : mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
6761 : else
6762 : {
6763 36 : gfc_set_model_kind (kind);
6764 36 : mpfr_fmod (result->value.real, a->value.real, p->value.real,
6765 : GFC_RND_MODE);
6766 36 : if (mpfr_cmp_ui (result->value.real, 0) != 0)
6767 : {
6768 12 : if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
6769 6 : mpfr_add (result->value.real, result->value.real, p->value.real,
6770 : GFC_RND_MODE);
6771 : }
6772 : else
6773 24 : mpfr_copysign (result->value.real, result->value.real,
6774 : p->value.real, GFC_RND_MODE);
6775 : }
6776 :
6777 253 : return range_check (result, "MODULO");
6778 : }
6779 :
6780 :
6781 : gfc_expr *
6782 6325 : gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
6783 : {
6784 6325 : gfc_expr *result;
6785 6325 : mpfr_exp_t emin, emax;
6786 6325 : int kind;
6787 :
6788 6325 : if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
6789 : return NULL;
6790 :
6791 891 : result = gfc_copy_expr (x);
6792 :
6793 : /* Save current values of emin and emax. */
6794 891 : emin = mpfr_get_emin ();
6795 891 : emax = mpfr_get_emax ();
6796 :
6797 : /* Set emin and emax for the current model number. */
6798 891 : kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
6799 891 : mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent -
6800 891 : mpfr_get_prec(result->value.real) + 1);
6801 891 : mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent);
6802 891 : mpfr_check_range (result->value.real, 0, MPFR_RNDU);
6803 :
6804 891 : if (mpfr_sgn (s->value.real) > 0)
6805 : {
6806 414 : mpfr_nextabove (result->value.real);
6807 414 : mpfr_subnormalize (result->value.real, 0, MPFR_RNDU);
6808 : }
6809 : else
6810 : {
6811 477 : mpfr_nextbelow (result->value.real);
6812 477 : mpfr_subnormalize (result->value.real, 0, MPFR_RNDD);
6813 : }
6814 :
6815 891 : mpfr_set_emin (emin);
6816 891 : mpfr_set_emax (emax);
6817 :
6818 : /* Only NaN can occur. Do not use range check as it gives an
6819 : error for denormal numbers. */
6820 891 : if (mpfr_nan_p (result->value.real) && flag_range_check)
6821 : {
6822 0 : gfc_error ("Result of NEAREST is NaN at %L", &result->where);
6823 0 : gfc_free_expr (result);
6824 0 : return &gfc_bad_expr;
6825 : }
6826 :
6827 : return result;
6828 : }
6829 :
6830 :
6831 : static gfc_expr *
6832 518 : simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
6833 : {
6834 518 : gfc_expr *itrunc, *result;
6835 518 : int kind;
6836 :
6837 518 : kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
6838 518 : if (kind == -1)
6839 : return &gfc_bad_expr;
6840 :
6841 518 : if (e->expr_type != EXPR_CONSTANT)
6842 : return NULL;
6843 :
6844 156 : itrunc = gfc_copy_expr (e);
6845 156 : mpfr_round (itrunc->value.real, e->value.real);
6846 :
6847 156 : result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
6848 156 : gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
6849 :
6850 156 : gfc_free_expr (itrunc);
6851 :
6852 156 : return range_check (result, name);
6853 : }
6854 :
6855 :
6856 : gfc_expr *
6857 331 : gfc_simplify_new_line (gfc_expr *e)
6858 : {
6859 331 : gfc_expr *result;
6860 :
6861 331 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
6862 331 : result->value.character.string[0] = '\n';
6863 :
6864 331 : return result;
6865 : }
6866 :
6867 :
6868 : gfc_expr *
6869 406 : gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
6870 : {
6871 406 : return simplify_nint ("NINT", e, k);
6872 : }
6873 :
6874 :
6875 : gfc_expr *
6876 112 : gfc_simplify_idnint (gfc_expr *e)
6877 : {
6878 112 : return simplify_nint ("IDNINT", e, NULL);
6879 : }
6880 :
6881 : static int norm2_scale;
6882 :
6883 : static gfc_expr *
6884 124 : norm2_add_squared (gfc_expr *result, gfc_expr *e)
6885 : {
6886 124 : mpfr_t tmp;
6887 :
6888 124 : gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6889 124 : gcc_assert (result->ts.type == BT_REAL
6890 : && result->expr_type == EXPR_CONSTANT);
6891 :
6892 124 : gfc_set_model_kind (result->ts.kind);
6893 124 : int index = gfc_validate_kind (BT_REAL, result->ts.kind, false);
6894 124 : mpfr_exp_t exp;
6895 124 : if (mpfr_regular_p (result->value.real))
6896 : {
6897 61 : exp = mpfr_get_exp (result->value.real);
6898 : /* If result is getting close to overflowing, scale down. */
6899 61 : if (exp >= gfc_real_kinds[index].max_exponent - 4
6900 0 : && norm2_scale <= gfc_real_kinds[index].max_exponent - 2)
6901 : {
6902 0 : norm2_scale += 2;
6903 0 : mpfr_div_ui (result->value.real, result->value.real, 16,
6904 : GFC_RND_MODE);
6905 : }
6906 : }
6907 :
6908 124 : mpfr_init (tmp);
6909 124 : if (mpfr_regular_p (e->value.real))
6910 : {
6911 88 : exp = mpfr_get_exp (e->value.real);
6912 : /* If e**2 would overflow or close to overflowing, scale down. */
6913 88 : if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2)
6914 : {
6915 12 : int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4;
6916 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6917 12 : mpfr_set_exp (tmp, new_scale - norm2_scale);
6918 12 : mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6919 12 : mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6920 12 : norm2_scale = new_scale;
6921 : }
6922 : }
6923 124 : if (norm2_scale)
6924 : {
6925 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6926 12 : mpfr_set_exp (tmp, norm2_scale);
6927 12 : mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE);
6928 : }
6929 : else
6930 112 : mpfr_set (tmp, e->value.real, GFC_RND_MODE);
6931 124 : mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE);
6932 124 : mpfr_add (result->value.real, result->value.real, tmp,
6933 : GFC_RND_MODE);
6934 124 : mpfr_clear (tmp);
6935 :
6936 124 : return result;
6937 : }
6938 :
6939 :
6940 : static gfc_expr *
6941 2 : norm2_do_sqrt (gfc_expr *result, gfc_expr *e)
6942 : {
6943 2 : gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6944 2 : gcc_assert (result->ts.type == BT_REAL
6945 : && result->expr_type == EXPR_CONSTANT);
6946 :
6947 2 : if (result != e)
6948 0 : mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
6949 2 : mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6950 2 : if (norm2_scale && mpfr_regular_p (result->value.real))
6951 : {
6952 0 : mpfr_t tmp;
6953 0 : mpfr_init (tmp);
6954 0 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6955 0 : mpfr_set_exp (tmp, norm2_scale);
6956 0 : mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6957 0 : mpfr_clear (tmp);
6958 : }
6959 2 : norm2_scale = 0;
6960 :
6961 2 : return result;
6962 : }
6963 :
6964 :
6965 : gfc_expr *
6966 449 : gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
6967 : {
6968 449 : gfc_expr *result;
6969 449 : bool size_zero;
6970 :
6971 449 : size_zero = gfc_is_size_zero_array (e);
6972 :
6973 835 : if (!(is_constant_array_expr (e) || size_zero)
6974 449 : || (dim != NULL && !gfc_is_constant_expr (dim)))
6975 : return NULL;
6976 :
6977 63 : result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
6978 63 : init_result_expr (result, 0, NULL);
6979 :
6980 63 : if (size_zero)
6981 : return result;
6982 :
6983 38 : norm2_scale = 0;
6984 38 : if (!dim || e->rank == 1)
6985 : {
6986 37 : result = simplify_transformation_to_scalar (result, e, NULL,
6987 : norm2_add_squared);
6988 37 : mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6989 37 : if (norm2_scale && mpfr_regular_p (result->value.real))
6990 : {
6991 12 : mpfr_t tmp;
6992 12 : mpfr_init (tmp);
6993 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6994 12 : mpfr_set_exp (tmp, norm2_scale);
6995 12 : mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6996 12 : mpfr_clear (tmp);
6997 : }
6998 37 : norm2_scale = 0;
6999 37 : }
7000 : else
7001 1 : result = simplify_transformation_to_array (result, e, dim, NULL,
7002 : norm2_add_squared,
7003 : norm2_do_sqrt);
7004 :
7005 : return result;
7006 : }
7007 :
7008 :
7009 : gfc_expr *
7010 602 : gfc_simplify_not (gfc_expr *e)
7011 : {
7012 602 : gfc_expr *result;
7013 :
7014 602 : if (e->expr_type != EXPR_CONSTANT)
7015 : return NULL;
7016 :
7017 211 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
7018 211 : mpz_com (result->value.integer, e->value.integer);
7019 :
7020 211 : return range_check (result, "NOT");
7021 : }
7022 :
7023 :
7024 : gfc_expr *
7025 1979 : gfc_simplify_null (gfc_expr *mold)
7026 : {
7027 1979 : gfc_expr *result;
7028 :
7029 1979 : if (mold)
7030 : {
7031 564 : result = gfc_copy_expr (mold);
7032 564 : result->expr_type = EXPR_NULL;
7033 : }
7034 : else
7035 1415 : result = gfc_get_null_expr (NULL);
7036 :
7037 1979 : return result;
7038 : }
7039 :
7040 :
7041 : gfc_expr *
7042 2288 : gfc_simplify_num_images (gfc_expr *team ATTRIBUTE_UNUSED,
7043 : gfc_expr *team_number ATTRIBUTE_UNUSED)
7044 : {
7045 2288 : gfc_expr *result;
7046 :
7047 2288 : if (flag_coarray == GFC_FCOARRAY_NONE)
7048 : {
7049 0 : gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
7050 : return &gfc_bad_expr;
7051 : }
7052 :
7053 2288 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
7054 : return NULL;
7055 :
7056 : /* FIXME: gfc_current_locus is wrong. */
7057 462 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
7058 : &gfc_current_locus);
7059 462 : mpz_set_si (result->value.integer, 1);
7060 :
7061 462 : return result;
7062 : }
7063 :
7064 :
7065 : gfc_expr *
7066 20 : gfc_simplify_or (gfc_expr *x, gfc_expr *y)
7067 : {
7068 20 : gfc_expr *result;
7069 20 : int kind;
7070 :
7071 20 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
7072 : return NULL;
7073 :
7074 6 : kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
7075 :
7076 6 : switch (x->ts.type)
7077 : {
7078 0 : case BT_INTEGER:
7079 0 : result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
7080 0 : mpz_ior (result->value.integer, x->value.integer, y->value.integer);
7081 0 : return range_check (result, "OR");
7082 :
7083 6 : case BT_LOGICAL:
7084 6 : return gfc_get_logical_expr (kind, &x->where,
7085 12 : x->value.logical || y->value.logical);
7086 0 : default:
7087 0 : gcc_unreachable();
7088 : }
7089 : }
7090 :
7091 :
7092 : gfc_expr *
7093 1602 : gfc_simplify_out_of_range (gfc_expr *x, gfc_expr *mold, gfc_expr *round)
7094 : {
7095 1602 : gfc_expr *result;
7096 1602 : mpfr_t a;
7097 1602 : mpz_t b;
7098 1602 : int i, k;
7099 1602 : bool res = false;
7100 1602 : bool rnd = false;
7101 :
7102 1602 : i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
7103 1602 : k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
7104 :
7105 1602 : mpfr_init (a);
7106 :
7107 1602 : switch (x->ts.type)
7108 : {
7109 1242 : case BT_REAL:
7110 1242 : if (mold->ts.type == BT_REAL)
7111 : {
7112 90 : if (mpfr_cmp (gfc_real_kinds[i].huge,
7113 : gfc_real_kinds[k].huge) <= 0)
7114 : {
7115 : /* Range of MOLD is always sufficient. */
7116 42 : res = false;
7117 42 : goto done;
7118 : }
7119 48 : else if (x->expr_type == EXPR_CONSTANT)
7120 : {
7121 0 : mpfr_neg (a, gfc_real_kinds[k].huge, GFC_RND_MODE);
7122 0 : res = (mpfr_cmp (x->value.real, a) < 0
7123 0 : || mpfr_cmp (x->value.real, gfc_real_kinds[k].huge) > 0);
7124 0 : goto done;
7125 : }
7126 : }
7127 1152 : else if (mold->ts.type == BT_INTEGER)
7128 : {
7129 582 : if (x->expr_type == EXPR_CONSTANT)
7130 : {
7131 48 : res = mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real);
7132 48 : if (res)
7133 0 : goto done;
7134 :
7135 48 : if (round && round->expr_type != EXPR_CONSTANT)
7136 : break;
7137 :
7138 24 : if (round && round->expr_type == EXPR_CONSTANT)
7139 24 : rnd = round->value.logical;
7140 :
7141 48 : if (rnd)
7142 24 : mpfr_round (a, x->value.real);
7143 : else
7144 24 : mpfr_trunc (a, x->value.real);
7145 :
7146 48 : mpz_init (b);
7147 48 : mpfr_get_z (b, a, GFC_RND_MODE);
7148 96 : res = (mpz_cmp (b, gfc_integer_kinds[k].min_int) < 0
7149 48 : || mpz_cmp (b, gfc_integer_kinds[k].huge) > 0);
7150 48 : mpz_clear (b);
7151 48 : goto done;
7152 : }
7153 : }
7154 570 : else if (mold->ts.type == BT_UNSIGNED)
7155 : {
7156 570 : if (x->expr_type == EXPR_CONSTANT)
7157 : {
7158 48 : res = mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real);
7159 48 : if (res)
7160 0 : goto done;
7161 :
7162 48 : if (round && round->expr_type != EXPR_CONSTANT)
7163 : break;
7164 :
7165 24 : if (round && round->expr_type == EXPR_CONSTANT)
7166 24 : rnd = round->value.logical;
7167 :
7168 24 : if (rnd)
7169 24 : mpfr_round (a, x->value.real);
7170 : else
7171 24 : mpfr_trunc (a, x->value.real);
7172 :
7173 48 : mpz_init (b);
7174 48 : mpfr_get_z (b, a, GFC_RND_MODE);
7175 96 : res = (mpz_cmp (b, gfc_unsigned_kinds[k].huge) > 0
7176 48 : || mpz_cmp_si (b, 0) < 0);
7177 48 : mpz_clear (b);
7178 48 : goto done;
7179 : }
7180 : }
7181 : break;
7182 :
7183 168 : case BT_INTEGER:
7184 168 : gcc_assert (round == NULL);
7185 168 : if (mold->ts.type == BT_INTEGER)
7186 : {
7187 54 : if (mpz_cmp (gfc_integer_kinds[i].huge,
7188 54 : gfc_integer_kinds[k].huge) <= 0)
7189 : {
7190 : /* Range of MOLD is always sufficient. */
7191 18 : res = false;
7192 18 : goto done;
7193 : }
7194 36 : else if (x->expr_type == EXPR_CONSTANT)
7195 : {
7196 0 : res = (mpz_cmp (x->value.integer,
7197 0 : gfc_integer_kinds[k].min_int) < 0
7198 0 : || mpz_cmp (x->value.integer,
7199 : gfc_integer_kinds[k].huge) > 0);
7200 0 : goto done;
7201 : }
7202 : }
7203 114 : else if (mold->ts.type == BT_UNSIGNED)
7204 : {
7205 90 : if (x->expr_type == EXPR_CONSTANT)
7206 : {
7207 0 : res = (mpz_cmp_si (x->value.integer, 0) < 0
7208 0 : || mpz_cmp (x->value.integer,
7209 0 : gfc_unsigned_kinds[k].huge) > 0);
7210 0 : goto done;
7211 : }
7212 : }
7213 24 : else if (mold->ts.type == BT_REAL)
7214 : {
7215 24 : mpfr_set_z (a, gfc_integer_kinds[i].min_int, GFC_RND_MODE);
7216 24 : mpfr_neg (a, a, GFC_RND_MODE);
7217 24 : res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
7218 : /* When false, range of MOLD is always sufficient. */
7219 24 : if (!res)
7220 24 : goto done;
7221 :
7222 0 : if (x->expr_type == EXPR_CONSTANT)
7223 : {
7224 0 : mpfr_set_z (a, x->value.integer, GFC_RND_MODE);
7225 0 : mpfr_abs (a, a, GFC_RND_MODE);
7226 0 : res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
7227 0 : goto done;
7228 : }
7229 : }
7230 : break;
7231 :
7232 192 : case BT_UNSIGNED:
7233 192 : gcc_assert (round == NULL);
7234 192 : if (mold->ts.type == BT_UNSIGNED)
7235 : {
7236 54 : if (mpz_cmp (gfc_unsigned_kinds[i].huge,
7237 54 : gfc_unsigned_kinds[k].huge) <= 0)
7238 : {
7239 : /* Range of MOLD is always sufficient. */
7240 18 : res = false;
7241 18 : goto done;
7242 : }
7243 36 : else if (x->expr_type == EXPR_CONSTANT)
7244 : {
7245 0 : res = mpz_cmp (x->value.integer,
7246 : gfc_unsigned_kinds[k].huge) > 0;
7247 0 : goto done;
7248 : }
7249 : }
7250 138 : else if (mold->ts.type == BT_INTEGER)
7251 : {
7252 60 : if (mpz_cmp (gfc_unsigned_kinds[i].huge,
7253 60 : gfc_integer_kinds[k].huge) <= 0)
7254 : {
7255 : /* Range of MOLD is always sufficient. */
7256 6 : res = false;
7257 6 : goto done;
7258 : }
7259 54 : else if (x->expr_type == EXPR_CONSTANT)
7260 : {
7261 0 : res = mpz_cmp (x->value.integer,
7262 : gfc_integer_kinds[k].huge) > 0;
7263 0 : goto done;
7264 : }
7265 : }
7266 78 : else if (mold->ts.type == BT_REAL)
7267 : {
7268 78 : mpfr_set_z (a, gfc_unsigned_kinds[i].huge, GFC_RND_MODE);
7269 78 : res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
7270 : /* When false, range of MOLD is always sufficient. */
7271 78 : if (!res)
7272 36 : goto done;
7273 :
7274 42 : if (x->expr_type == EXPR_CONSTANT)
7275 : {
7276 12 : mpfr_set_z (a, x->value.integer, GFC_RND_MODE);
7277 12 : res = mpfr_cmp (a, gfc_real_kinds[k].huge) > 0;
7278 12 : goto done;
7279 : }
7280 : }
7281 : break;
7282 :
7283 0 : default:
7284 0 : gcc_unreachable ();
7285 : }
7286 :
7287 1350 : mpfr_clear (a);
7288 :
7289 1350 : return NULL;
7290 :
7291 252 : done:
7292 252 : result = gfc_get_logical_expr (gfc_default_logical_kind, &x->where, res);
7293 :
7294 252 : mpfr_clear (a);
7295 :
7296 252 : return result;
7297 : }
7298 :
7299 :
7300 : gfc_expr *
7301 994 : gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
7302 : {
7303 994 : gfc_expr *result;
7304 994 : gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
7305 :
7306 994 : if (!is_constant_array_expr (array)
7307 58 : || !is_constant_array_expr (vector)
7308 1052 : || (!gfc_is_constant_expr (mask)
7309 2 : && !is_constant_array_expr (mask)))
7310 : return NULL;
7311 :
7312 57 : result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
7313 57 : if (array->ts.type == BT_DERIVED)
7314 5 : result->ts.u.derived = array->ts.u.derived;
7315 :
7316 57 : array_ctor = gfc_constructor_first (array->value.constructor);
7317 57 : vector_ctor = vector
7318 57 : ? gfc_constructor_first (vector->value.constructor)
7319 : : NULL;
7320 :
7321 57 : if (mask->expr_type == EXPR_CONSTANT
7322 0 : && mask->value.logical)
7323 : {
7324 : /* Copy all elements of ARRAY to RESULT. */
7325 0 : while (array_ctor)
7326 : {
7327 0 : gfc_constructor_append_expr (&result->value.constructor,
7328 : gfc_copy_expr (array_ctor->expr),
7329 : NULL);
7330 :
7331 0 : array_ctor = gfc_constructor_next (array_ctor);
7332 0 : vector_ctor = gfc_constructor_next (vector_ctor);
7333 : }
7334 : }
7335 57 : else if (mask->expr_type == EXPR_ARRAY)
7336 : {
7337 : /* Copy only those elements of ARRAY to RESULT whose
7338 : MASK equals .TRUE.. */
7339 57 : mask_ctor = gfc_constructor_first (mask->value.constructor);
7340 303 : while (mask_ctor && array_ctor)
7341 : {
7342 189 : if (mask_ctor->expr->value.logical)
7343 : {
7344 130 : gfc_constructor_append_expr (&result->value.constructor,
7345 : gfc_copy_expr (array_ctor->expr),
7346 : NULL);
7347 130 : vector_ctor = gfc_constructor_next (vector_ctor);
7348 : }
7349 :
7350 189 : array_ctor = gfc_constructor_next (array_ctor);
7351 189 : mask_ctor = gfc_constructor_next (mask_ctor);
7352 : }
7353 : }
7354 :
7355 : /* Append any left-over elements from VECTOR to RESULT. */
7356 85 : while (vector_ctor)
7357 : {
7358 28 : gfc_constructor_append_expr (&result->value.constructor,
7359 : gfc_copy_expr (vector_ctor->expr),
7360 : NULL);
7361 28 : vector_ctor = gfc_constructor_next (vector_ctor);
7362 : }
7363 :
7364 57 : result->shape = gfc_get_shape (1);
7365 57 : gfc_array_size (result, &result->shape[0]);
7366 :
7367 57 : if (array->ts.type == BT_CHARACTER)
7368 51 : result->ts.u.cl = array->ts.u.cl;
7369 :
7370 : return result;
7371 : }
7372 :
7373 :
7374 : static gfc_expr *
7375 124 : do_xor (gfc_expr *result, gfc_expr *e)
7376 : {
7377 124 : gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
7378 124 : gcc_assert (result->ts.type == BT_LOGICAL
7379 : && result->expr_type == EXPR_CONSTANT);
7380 :
7381 124 : result->value.logical = result->value.logical != e->value.logical;
7382 124 : return result;
7383 : }
7384 :
7385 :
7386 : gfc_expr *
7387 1185 : gfc_simplify_is_contiguous (gfc_expr *array)
7388 : {
7389 1185 : if (gfc_is_simply_contiguous (array, false, true))
7390 45 : return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);
7391 :
7392 1140 : if (gfc_is_not_contiguous (array))
7393 54 : return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
7394 :
7395 : return NULL;
7396 : }
7397 :
7398 :
7399 : gfc_expr *
7400 147 : gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
7401 : {
7402 147 : return simplify_transformation (e, dim, NULL, 0, do_xor);
7403 : }
7404 :
7405 :
7406 : gfc_expr *
7407 1064 : gfc_simplify_popcnt (gfc_expr *e)
7408 : {
7409 1064 : int res, k;
7410 1064 : mpz_t x;
7411 :
7412 1064 : if (e->expr_type != EXPR_CONSTANT)
7413 : return NULL;
7414 :
7415 642 : k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
7416 :
7417 642 : if (flag_unsigned && e->ts.type == BT_UNSIGNED)
7418 0 : res = mpz_popcount (e->value.integer);
7419 : else
7420 : {
7421 : /* Convert argument to unsigned, then count the '1' bits. */
7422 642 : mpz_init_set (x, e->value.integer);
7423 642 : gfc_convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
7424 642 : res = mpz_popcount (x);
7425 642 : mpz_clear (x);
7426 : }
7427 :
7428 642 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
7429 : }
7430 :
7431 :
7432 : gfc_expr *
7433 362 : gfc_simplify_poppar (gfc_expr *e)
7434 : {
7435 362 : gfc_expr *popcnt;
7436 362 : int i;
7437 :
7438 362 : if (e->expr_type != EXPR_CONSTANT)
7439 : return NULL;
7440 :
7441 300 : popcnt = gfc_simplify_popcnt (e);
7442 300 : gcc_assert (popcnt);
7443 :
7444 300 : bool fail = gfc_extract_int (popcnt, &i);
7445 300 : gcc_assert (!fail);
7446 :
7447 300 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
7448 : }
7449 :
7450 :
7451 : gfc_expr *
7452 461 : gfc_simplify_precision (gfc_expr *e)
7453 : {
7454 461 : int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
7455 461 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
7456 461 : gfc_real_kinds[i].precision);
7457 : }
7458 :
7459 :
7460 : gfc_expr *
7461 849 : gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
7462 : {
7463 849 : return simplify_transformation (array, dim, mask, 1, gfc_multiply);
7464 : }
7465 :
7466 :
7467 : gfc_expr *
7468 61 : gfc_simplify_radix (gfc_expr *e)
7469 : {
7470 61 : int i;
7471 61 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
7472 :
7473 61 : switch (e->ts.type)
7474 : {
7475 0 : case BT_INTEGER:
7476 0 : i = gfc_integer_kinds[i].radix;
7477 0 : break;
7478 :
7479 61 : case BT_REAL:
7480 61 : i = gfc_real_kinds[i].radix;
7481 61 : break;
7482 :
7483 0 : default:
7484 0 : gcc_unreachable ();
7485 : }
7486 :
7487 61 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
7488 : }
7489 :
7490 :
7491 : gfc_expr *
7492 180 : gfc_simplify_range (gfc_expr *e)
7493 : {
7494 180 : int i;
7495 180 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
7496 :
7497 180 : switch (e->ts.type)
7498 : {
7499 85 : case BT_INTEGER:
7500 85 : i = gfc_integer_kinds[i].range;
7501 85 : break;
7502 :
7503 24 : case BT_UNSIGNED:
7504 24 : i = gfc_unsigned_kinds[i].range;
7505 24 : break;
7506 :
7507 71 : case BT_REAL:
7508 71 : case BT_COMPLEX:
7509 71 : i = gfc_real_kinds[i].range;
7510 71 : break;
7511 :
7512 0 : default:
7513 0 : gcc_unreachable ();
7514 : }
7515 :
7516 180 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
7517 : }
7518 :
7519 :
7520 : gfc_expr *
7521 9575 : gfc_simplify_rank (gfc_expr *e)
7522 : {
7523 : /* Assumed rank. */
7524 9575 : if (e->rank == -1)
7525 : return NULL;
7526 :
7527 618 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
7528 : }
7529 :
7530 :
7531 : gfc_expr *
7532 31636 : gfc_simplify_real (gfc_expr *e, gfc_expr *k)
7533 : {
7534 31636 : gfc_expr *result = NULL;
7535 31636 : int kind, tmp1, tmp2;
7536 :
7537 : /* Convert BOZ to real, and return without range checking. */
7538 31636 : if (e->ts.type == BT_BOZ)
7539 : {
7540 : /* Determine kind for conversion of the BOZ. */
7541 85 : if (k)
7542 63 : gfc_extract_int (k, &kind);
7543 : else
7544 22 : kind = gfc_default_real_kind;
7545 :
7546 85 : if (!gfc_boz2real (e, kind))
7547 : return NULL;
7548 85 : result = gfc_copy_expr (e);
7549 85 : return result;
7550 : }
7551 :
7552 31551 : if (e->ts.type == BT_COMPLEX)
7553 2035 : kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
7554 : else
7555 29516 : kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
7556 :
7557 31551 : if (kind == -1)
7558 : return &gfc_bad_expr;
7559 :
7560 31551 : if (e->expr_type != EXPR_CONSTANT)
7561 : return NULL;
7562 :
7563 : /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
7564 : warnings. */
7565 25446 : tmp1 = warn_conversion;
7566 25446 : tmp2 = warn_conversion_extra;
7567 25446 : warn_conversion = warn_conversion_extra = 0;
7568 :
7569 25446 : result = gfc_convert_constant (e, BT_REAL, kind);
7570 :
7571 25446 : warn_conversion = tmp1;
7572 25446 : warn_conversion_extra = tmp2;
7573 :
7574 25446 : if (result == &gfc_bad_expr)
7575 : return &gfc_bad_expr;
7576 :
7577 25445 : return range_check (result, "REAL");
7578 : }
7579 :
7580 :
7581 : gfc_expr *
7582 7 : gfc_simplify_realpart (gfc_expr *e)
7583 : {
7584 7 : gfc_expr *result;
7585 :
7586 7 : if (e->expr_type != EXPR_CONSTANT)
7587 : return NULL;
7588 :
7589 1 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
7590 1 : mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
7591 :
7592 1 : return range_check (result, "REALPART");
7593 : }
7594 :
7595 : gfc_expr *
7596 2683 : gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
7597 : {
7598 2683 : gfc_expr *result;
7599 2683 : gfc_charlen_t len;
7600 2683 : mpz_t ncopies;
7601 2683 : bool have_length = false;
7602 :
7603 : /* If NCOPIES isn't a constant, there's nothing we can do. */
7604 2683 : if (n->expr_type != EXPR_CONSTANT)
7605 : return NULL;
7606 :
7607 : /* If NCOPIES is negative, it's an error. */
7608 2107 : if (mpz_sgn (n->value.integer) < 0)
7609 : {
7610 6 : gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
7611 : &n->where);
7612 6 : return &gfc_bad_expr;
7613 : }
7614 :
7615 : /* If we don't know the character length, we can do no more. */
7616 2101 : if (e->ts.u.cl && e->ts.u.cl->length
7617 426 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7618 : {
7619 426 : len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer);
7620 426 : have_length = true;
7621 : }
7622 1675 : else if (e->expr_type == EXPR_CONSTANT
7623 1675 : && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
7624 : {
7625 1675 : len = e->value.character.length;
7626 : }
7627 : else
7628 : return NULL;
7629 :
7630 : /* If the source length is 0, any value of NCOPIES is valid
7631 : and everything behaves as if NCOPIES == 0. */
7632 2101 : mpz_init (ncopies);
7633 2101 : if (len == 0)
7634 63 : mpz_set_ui (ncopies, 0);
7635 : else
7636 2038 : mpz_set (ncopies, n->value.integer);
7637 :
7638 : /* Check that NCOPIES isn't too large. */
7639 2101 : if (len)
7640 : {
7641 2038 : mpz_t max, mlen;
7642 2038 : int i;
7643 :
7644 : /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
7645 2038 : mpz_init (max);
7646 2038 : i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
7647 :
7648 2038 : if (have_length)
7649 : {
7650 369 : mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
7651 369 : e->ts.u.cl->length->value.integer);
7652 : }
7653 : else
7654 : {
7655 1669 : mpz_init (mlen);
7656 1669 : gfc_mpz_set_hwi (mlen, len);
7657 1669 : mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
7658 1669 : mpz_clear (mlen);
7659 : }
7660 :
7661 : /* The check itself. */
7662 2038 : if (mpz_cmp (ncopies, max) > 0)
7663 : {
7664 4 : mpz_clear (max);
7665 4 : mpz_clear (ncopies);
7666 4 : gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
7667 : &n->where);
7668 4 : return &gfc_bad_expr;
7669 : }
7670 :
7671 2034 : mpz_clear (max);
7672 : }
7673 2097 : mpz_clear (ncopies);
7674 :
7675 : /* For further simplification, we need the character string to be
7676 : constant. */
7677 2097 : if (e->expr_type != EXPR_CONSTANT)
7678 : return NULL;
7679 :
7680 1736 : HOST_WIDE_INT ncop;
7681 1736 : if (len ||
7682 42 : (e->ts.u.cl->length &&
7683 18 : mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
7684 : {
7685 1712 : bool fail = gfc_extract_hwi (n, &ncop);
7686 1712 : gcc_assert (!fail);
7687 : }
7688 : else
7689 24 : ncop = 0;
7690 :
7691 1736 : if (ncop == 0)
7692 54 : return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
7693 :
7694 1682 : len = e->value.character.length;
7695 1682 : gfc_charlen_t nlen = ncop * len;
7696 :
7697 : /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
7698 : (2**28 elements * 4 bytes (wide chars) per element) defer to
7699 : runtime instead of consuming (unbounded) memory and CPU at
7700 : compile time. */
7701 1682 : if (nlen > 268435456)
7702 : {
7703 1 : gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
7704 : " deferred to runtime, expect bugs", &e->where);
7705 1 : return NULL;
7706 : }
7707 :
7708 1681 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
7709 62025 : for (size_t i = 0; i < (size_t) ncop; i++)
7710 117656 : for (size_t j = 0; j < (size_t) len; j++)
7711 58993 : result->value.character.string[j+i*len]= e->value.character.string[j];
7712 :
7713 1681 : result->value.character.string[nlen] = '\0'; /* For debugger */
7714 1681 : return result;
7715 : }
7716 :
7717 :
7718 : /* This one is a bear, but mainly has to do with shuffling elements. */
7719 :
7720 : gfc_expr *
7721 9974 : gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
7722 : gfc_expr *pad, gfc_expr *order_exp)
7723 : {
7724 9974 : int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
7725 9974 : int i, rank, npad, x[GFC_MAX_DIMENSIONS];
7726 9974 : mpz_t index, size;
7727 9974 : unsigned long j;
7728 9974 : size_t nsource;
7729 9974 : gfc_expr *e, *result;
7730 9974 : bool zerosize = false;
7731 :
7732 : /* Check that argument expression types are OK. */
7733 9974 : if (!is_constant_array_expr (source)
7734 8113 : || !is_constant_array_expr (shape_exp)
7735 6793 : || !is_constant_array_expr (pad)
7736 16767 : || !is_constant_array_expr (order_exp))
7737 : return NULL;
7738 :
7739 6781 : if (source->shape == NULL)
7740 : return NULL;
7741 :
7742 : /* Proceed with simplification, unpacking the array. */
7743 :
7744 6778 : mpz_init (index);
7745 6778 : rank = 0;
7746 :
7747 115226 : for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
7748 101670 : x[i] = 0;
7749 :
7750 38202 : for (;;)
7751 : {
7752 22490 : e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
7753 22490 : if (e == NULL)
7754 : break;
7755 :
7756 15712 : gfc_extract_int (e, &shape[rank]);
7757 :
7758 15712 : gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
7759 15712 : if (shape[rank] < 0)
7760 : {
7761 0 : gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
7762 : "negative value %d for dimension %d",
7763 : &shape_exp->where, shape[rank], rank+1);
7764 0 : mpz_clear (index);
7765 0 : return &gfc_bad_expr;
7766 : }
7767 :
7768 15712 : rank++;
7769 : }
7770 :
7771 6778 : gcc_assert (rank > 0);
7772 :
7773 : /* Now unpack the order array if present. */
7774 6778 : if (order_exp == NULL)
7775 : {
7776 22424 : for (i = 0; i < rank; i++)
7777 15668 : order[i] = i;
7778 : }
7779 : else
7780 : {
7781 22 : mpz_t size;
7782 22 : int order_size, shape_size;
7783 :
7784 22 : if (order_exp->rank != shape_exp->rank)
7785 : {
7786 1 : gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
7787 : &order_exp->where, &shape_exp->where);
7788 1 : mpz_clear (index);
7789 4 : return &gfc_bad_expr;
7790 : }
7791 :
7792 21 : gfc_array_size (shape_exp, &size);
7793 21 : shape_size = mpz_get_ui (size);
7794 21 : mpz_clear (size);
7795 21 : gfc_array_size (order_exp, &size);
7796 21 : order_size = mpz_get_ui (size);
7797 21 : mpz_clear (size);
7798 21 : if (order_size != shape_size)
7799 : {
7800 1 : gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
7801 : &order_exp->where, &shape_exp->where);
7802 1 : mpz_clear (index);
7803 1 : return &gfc_bad_expr;
7804 : }
7805 :
7806 58 : for (i = 0; i < rank; i++)
7807 : {
7808 40 : e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
7809 40 : gcc_assert (e);
7810 :
7811 40 : gfc_extract_int (e, &order[i]);
7812 :
7813 40 : if (order[i] < 1 || order[i] > rank)
7814 : {
7815 1 : gfc_error ("Element with a value of %d in ORDER at %L must be "
7816 : "in the range [1, ..., %d] for the RESHAPE intrinsic "
7817 : "near %L", order[i], &order_exp->where, rank,
7818 : &shape_exp->where);
7819 1 : mpz_clear (index);
7820 1 : return &gfc_bad_expr;
7821 : }
7822 :
7823 39 : order[i]--;
7824 39 : if (x[order[i]] != 0)
7825 : {
7826 1 : gfc_error ("ORDER at %L is not a permutation of the size of "
7827 : "SHAPE at %L", &order_exp->where, &shape_exp->where);
7828 1 : mpz_clear (index);
7829 1 : return &gfc_bad_expr;
7830 : }
7831 38 : x[order[i]] = 1;
7832 : }
7833 : }
7834 :
7835 : /* Count the elements in the source and padding arrays. */
7836 :
7837 6774 : npad = 0;
7838 6774 : if (pad != NULL)
7839 : {
7840 56 : gfc_array_size (pad, &size);
7841 56 : npad = mpz_get_ui (size);
7842 56 : mpz_clear (size);
7843 : }
7844 :
7845 6774 : gfc_array_size (source, &size);
7846 6774 : nsource = mpz_get_ui (size);
7847 6774 : mpz_clear (size);
7848 :
7849 : /* If it weren't for that pesky permutation we could just loop
7850 : through the source and round out any shortage with pad elements.
7851 : But no, someone just had to have the compiler do something the
7852 : user should be doing. */
7853 :
7854 29252 : for (i = 0; i < rank; i++)
7855 15704 : x[i] = 0;
7856 :
7857 6774 : result = gfc_get_array_expr (source->ts.type, source->ts.kind,
7858 : &source->where);
7859 6774 : if (source->ts.type == BT_DERIVED)
7860 116 : result->ts.u.derived = source->ts.u.derived;
7861 6774 : if (source->ts.type == BT_CHARACTER && result->ts.u.cl == NULL)
7862 278 : result->ts = source->ts;
7863 6774 : result->rank = rank;
7864 6774 : result->shape = gfc_get_shape (rank);
7865 22478 : for (i = 0; i < rank; i++)
7866 : {
7867 15704 : mpz_init_set_ui (result->shape[i], shape[i]);
7868 15704 : if (shape[i] == 0)
7869 723 : zerosize = true;
7870 : }
7871 :
7872 6774 : if (zerosize)
7873 699 : goto sizezero;
7874 :
7875 115404 : while (nsource > 0 || npad > 0)
7876 : {
7877 : /* Figure out which element to extract. */
7878 115404 : mpz_set_ui (index, 0);
7879 :
7880 406528 : for (i = rank - 1; i >= 0; i--)
7881 : {
7882 291124 : mpz_add_ui (index, index, x[order[i]]);
7883 291124 : if (i != 0)
7884 175720 : mpz_mul_ui (index, index, shape[order[i - 1]]);
7885 : }
7886 :
7887 115404 : if (mpz_cmp_ui (index, INT_MAX) > 0)
7888 0 : gfc_internal_error ("Reshaped array too large at %C");
7889 :
7890 115404 : j = mpz_get_ui (index);
7891 :
7892 115404 : if (j < nsource)
7893 115213 : e = gfc_constructor_lookup_expr (source->value.constructor, j);
7894 : else
7895 : {
7896 191 : if (npad <= 0)
7897 : {
7898 19 : mpz_clear (index);
7899 19 : if (pad == NULL)
7900 19 : gfc_error ("Without padding, there are not enough elements "
7901 : "in the intrinsic RESHAPE source at %L to match "
7902 : "the shape", &source->where);
7903 19 : gfc_free_expr (result);
7904 19 : return NULL;
7905 : }
7906 172 : j = j - nsource;
7907 172 : j = j % npad;
7908 172 : e = gfc_constructor_lookup_expr (pad->value.constructor, j);
7909 : }
7910 115385 : gcc_assert (e);
7911 :
7912 115385 : gfc_constructor_append_expr (&result->value.constructor,
7913 : gfc_copy_expr (e), &e->where);
7914 :
7915 : /* Calculate the next element. */
7916 115385 : i = 0;
7917 :
7918 152768 : inc:
7919 152768 : if (++x[i] < shape[i])
7920 109329 : continue;
7921 43439 : x[i++] = 0;
7922 43439 : if (i < rank)
7923 37383 : goto inc;
7924 :
7925 : break;
7926 : }
7927 :
7928 0 : sizezero:
7929 :
7930 6755 : mpz_clear (index);
7931 :
7932 6755 : return result;
7933 : }
7934 :
7935 :
7936 : gfc_expr *
7937 192 : gfc_simplify_rrspacing (gfc_expr *x)
7938 : {
7939 192 : gfc_expr *result;
7940 192 : int i;
7941 192 : long int e, p;
7942 :
7943 192 : if (x->expr_type != EXPR_CONSTANT)
7944 : return NULL;
7945 :
7946 60 : i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
7947 :
7948 60 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7949 :
7950 : /* RRSPACING(+/- 0.0) = 0.0 */
7951 60 : if (mpfr_zero_p (x->value.real))
7952 : {
7953 12 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
7954 12 : return result;
7955 : }
7956 :
7957 : /* RRSPACING(inf) = NaN */
7958 48 : if (mpfr_inf_p (x->value.real))
7959 : {
7960 12 : mpfr_set_nan (result->value.real);
7961 12 : return result;
7962 : }
7963 :
7964 : /* RRSPACING(NaN) = same NaN */
7965 36 : if (mpfr_nan_p (x->value.real))
7966 : {
7967 6 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7968 6 : return result;
7969 : }
7970 :
7971 : /* | x * 2**(-e) | * 2**p. */
7972 30 : mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
7973 30 : e = - (long int) mpfr_get_exp (x->value.real);
7974 30 : mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
7975 :
7976 30 : p = (long int) gfc_real_kinds[i].digits;
7977 30 : mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
7978 :
7979 30 : return range_check (result, "RRSPACING");
7980 : }
7981 :
7982 :
7983 : gfc_expr *
7984 168 : gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
7985 : {
7986 168 : int k, neg_flag, power, exp_range;
7987 168 : mpfr_t scale, radix;
7988 168 : gfc_expr *result;
7989 :
7990 168 : if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
7991 : return NULL;
7992 :
7993 12 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7994 :
7995 12 : if (mpfr_zero_p (x->value.real))
7996 : {
7997 0 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
7998 0 : return result;
7999 : }
8000 :
8001 12 : k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
8002 :
8003 12 : exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
8004 :
8005 : /* This check filters out values of i that would overflow an int. */
8006 12 : if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
8007 12 : || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
8008 : {
8009 0 : gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
8010 0 : gfc_free_expr (result);
8011 0 : return &gfc_bad_expr;
8012 : }
8013 :
8014 : /* Compute scale = radix ** power. */
8015 12 : power = mpz_get_si (i->value.integer);
8016 :
8017 12 : if (power >= 0)
8018 : neg_flag = 0;
8019 : else
8020 : {
8021 0 : neg_flag = 1;
8022 0 : power = -power;
8023 : }
8024 :
8025 12 : gfc_set_model_kind (x->ts.kind);
8026 12 : mpfr_init (scale);
8027 12 : mpfr_init (radix);
8028 12 : mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
8029 12 : mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
8030 :
8031 12 : if (neg_flag)
8032 0 : mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
8033 : else
8034 12 : mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
8035 :
8036 12 : mpfr_clears (scale, radix, NULL);
8037 :
8038 12 : return range_check (result, "SCALE");
8039 : }
8040 :
8041 :
8042 : /* Variants of strspn and strcspn that operate on wide characters. */
8043 :
8044 : static size_t
8045 60 : wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
8046 : {
8047 60 : size_t i = 0;
8048 60 : const gfc_char_t *c;
8049 :
8050 144 : while (s1[i])
8051 : {
8052 354 : for (c = s2; *c; c++)
8053 : {
8054 294 : if (s1[i] == *c)
8055 : break;
8056 : }
8057 144 : if (*c == '\0')
8058 : break;
8059 84 : i++;
8060 : }
8061 :
8062 60 : return i;
8063 : }
8064 :
8065 : static size_t
8066 60 : wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
8067 : {
8068 60 : size_t i = 0;
8069 60 : const gfc_char_t *c;
8070 :
8071 396 : while (s1[i])
8072 : {
8073 1392 : for (c = s2; *c; c++)
8074 : {
8075 1056 : if (s1[i] == *c)
8076 : break;
8077 : }
8078 384 : if (*c)
8079 : break;
8080 336 : i++;
8081 : }
8082 :
8083 60 : return i;
8084 : }
8085 :
8086 :
8087 : gfc_expr *
8088 958 : gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
8089 : {
8090 958 : gfc_expr *result;
8091 958 : int back;
8092 958 : size_t i;
8093 958 : size_t indx, len, lenc;
8094 958 : int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
8095 :
8096 958 : if (k == -1)
8097 : return &gfc_bad_expr;
8098 :
8099 958 : if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
8100 182 : || ( b != NULL && b->expr_type != EXPR_CONSTANT))
8101 : return NULL;
8102 :
8103 144 : if (b != NULL && b->value.logical != 0)
8104 : back = 1;
8105 : else
8106 72 : back = 0;
8107 :
8108 144 : len = e->value.character.length;
8109 144 : lenc = c->value.character.length;
8110 :
8111 144 : if (len == 0 || lenc == 0)
8112 : {
8113 : indx = 0;
8114 : }
8115 : else
8116 : {
8117 120 : if (back == 0)
8118 : {
8119 60 : indx = wide_strcspn (e->value.character.string,
8120 60 : c->value.character.string) + 1;
8121 60 : if (indx > len)
8122 48 : indx = 0;
8123 : }
8124 : else
8125 408 : for (indx = len; indx > 0; indx--)
8126 : {
8127 1488 : for (i = 0; i < lenc; i++)
8128 : {
8129 1140 : if (c->value.character.string[i]
8130 1140 : == e->value.character.string[indx - 1])
8131 : break;
8132 : }
8133 396 : if (i < lenc)
8134 : break;
8135 : }
8136 : }
8137 :
8138 144 : result = gfc_get_int_expr (k, &e->where, indx);
8139 144 : return range_check (result, "SCAN");
8140 : }
8141 :
8142 :
8143 : gfc_expr *
8144 289 : gfc_simplify_selected_char_kind (gfc_expr *e)
8145 : {
8146 289 : int kind;
8147 :
8148 289 : if (e->expr_type != EXPR_CONSTANT)
8149 : return NULL;
8150 :
8151 204 : if (gfc_compare_with_Cstring (e, "ascii", false) == 0
8152 204 : || gfc_compare_with_Cstring (e, "default", false) == 0)
8153 : kind = 1;
8154 108 : else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
8155 : kind = 4;
8156 : else
8157 39 : kind = -1;
8158 :
8159 204 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
8160 : }
8161 :
8162 :
8163 : gfc_expr *
8164 256 : gfc_simplify_selected_int_kind (gfc_expr *e)
8165 : {
8166 256 : int i, kind, range;
8167 :
8168 256 : if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
8169 : return NULL;
8170 :
8171 : kind = INT_MAX;
8172 :
8173 1242 : for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
8174 1035 : if (gfc_integer_kinds[i].range >= range
8175 539 : && gfc_integer_kinds[i].kind < kind)
8176 1035 : kind = gfc_integer_kinds[i].kind;
8177 :
8178 207 : if (kind == INT_MAX)
8179 0 : kind = -1;
8180 :
8181 207 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
8182 : }
8183 :
8184 : /* Same as above, but with unsigneds. */
8185 :
8186 : gfc_expr *
8187 25 : gfc_simplify_selected_unsigned_kind (gfc_expr *e)
8188 : {
8189 25 : int i, kind, range;
8190 :
8191 25 : if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
8192 : return NULL;
8193 :
8194 : kind = INT_MAX;
8195 :
8196 150 : for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
8197 125 : if (gfc_unsigned_kinds[i].range >= range
8198 86 : && gfc_unsigned_kinds[i].kind < kind)
8199 125 : kind = gfc_unsigned_kinds[i].kind;
8200 :
8201 25 : if (kind == INT_MAX)
8202 0 : kind = -1;
8203 :
8204 25 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
8205 : }
8206 :
8207 :
8208 : gfc_expr *
8209 78 : gfc_simplify_selected_logical_kind (gfc_expr *e)
8210 : {
8211 78 : int i, kind, bits;
8212 :
8213 78 : if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &bits))
8214 : return NULL;
8215 :
8216 : kind = INT_MAX;
8217 :
8218 396 : for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
8219 330 : if (gfc_logical_kinds[i].bit_size >= bits
8220 180 : && gfc_logical_kinds[i].kind < kind)
8221 330 : kind = gfc_logical_kinds[i].kind;
8222 :
8223 66 : if (kind == INT_MAX)
8224 6 : kind = -1;
8225 :
8226 66 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
8227 : }
8228 :
8229 :
8230 : gfc_expr *
8231 989 : gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
8232 : {
8233 989 : int range, precision, radix, i, kind, found_precision, found_range,
8234 : found_radix;
8235 989 : locus *loc = &gfc_current_locus;
8236 :
8237 989 : if (p == NULL)
8238 60 : precision = 0;
8239 : else
8240 : {
8241 929 : if (p->expr_type != EXPR_CONSTANT
8242 929 : || gfc_extract_int (p, &precision))
8243 : return NULL;
8244 883 : loc = &p->where;
8245 : }
8246 :
8247 943 : if (q == NULL)
8248 679 : range = 0;
8249 : else
8250 : {
8251 264 : if (q->expr_type != EXPR_CONSTANT
8252 264 : || gfc_extract_int (q, &range))
8253 : return NULL;
8254 :
8255 : if (!loc)
8256 : loc = &q->where;
8257 : }
8258 :
8259 889 : if (rdx == NULL)
8260 829 : radix = 0;
8261 : else
8262 : {
8263 60 : if (rdx->expr_type != EXPR_CONSTANT
8264 60 : || gfc_extract_int (rdx, &radix))
8265 : return NULL;
8266 :
8267 : if (!loc)
8268 : loc = &rdx->where;
8269 : }
8270 :
8271 865 : kind = INT_MAX;
8272 865 : found_precision = 0;
8273 865 : found_range = 0;
8274 865 : found_radix = 0;
8275 :
8276 4325 : for (i = 0; gfc_real_kinds[i].kind != 0; i++)
8277 : {
8278 3460 : if (gfc_real_kinds[i].precision >= precision)
8279 2340 : found_precision = 1;
8280 :
8281 3460 : if (gfc_real_kinds[i].range >= range)
8282 3340 : found_range = 1;
8283 :
8284 3460 : if (radix == 0 || gfc_real_kinds[i].radix == radix)
8285 3436 : found_radix = 1;
8286 :
8287 3460 : if (gfc_real_kinds[i].precision >= precision
8288 2340 : && gfc_real_kinds[i].range >= range
8289 2340 : && (radix == 0 || gfc_real_kinds[i].radix == radix)
8290 2316 : && gfc_real_kinds[i].kind < kind)
8291 3460 : kind = gfc_real_kinds[i].kind;
8292 : }
8293 :
8294 865 : if (kind == INT_MAX)
8295 : {
8296 12 : if (found_radix && found_range && !found_precision)
8297 : kind = -1;
8298 6 : else if (found_radix && found_precision && !found_range)
8299 : kind = -2;
8300 6 : else if (found_radix && !found_precision && !found_range)
8301 : kind = -3;
8302 6 : else if (found_radix)
8303 : kind = -4;
8304 : else
8305 6 : kind = -5;
8306 : }
8307 :
8308 865 : return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
8309 : }
8310 :
8311 :
8312 : gfc_expr *
8313 770 : gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
8314 : {
8315 770 : gfc_expr *result;
8316 770 : mpfr_t exp, absv, log2, pow2, frac;
8317 770 : long exp2;
8318 :
8319 770 : if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
8320 : return NULL;
8321 :
8322 150 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
8323 :
8324 : /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
8325 : SET_EXPONENT (NaN) = same NaN */
8326 150 : if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real))
8327 : {
8328 18 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
8329 18 : return result;
8330 : }
8331 :
8332 : /* SET_EXPONENT (inf) = NaN */
8333 132 : if (mpfr_inf_p (x->value.real))
8334 : {
8335 12 : mpfr_set_nan (result->value.real);
8336 12 : return result;
8337 : }
8338 :
8339 120 : gfc_set_model_kind (x->ts.kind);
8340 120 : mpfr_init (absv);
8341 120 : mpfr_init (log2);
8342 120 : mpfr_init (exp);
8343 120 : mpfr_init (pow2);
8344 120 : mpfr_init (frac);
8345 :
8346 120 : mpfr_abs (absv, x->value.real, GFC_RND_MODE);
8347 120 : mpfr_log2 (log2, absv, GFC_RND_MODE);
8348 :
8349 120 : mpfr_floor (log2, log2);
8350 120 : mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
8351 :
8352 : /* Old exponent value, and fraction. */
8353 120 : mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
8354 :
8355 120 : mpfr_div (frac, x->value.real, pow2, GFC_RND_MODE);
8356 :
8357 : /* New exponent. */
8358 120 : exp2 = mpz_get_si (i->value.integer);
8359 120 : mpfr_mul_2si (result->value.real, frac, exp2, GFC_RND_MODE);
8360 :
8361 120 : mpfr_clears (absv, log2, exp, pow2, frac, NULL);
8362 :
8363 120 : return range_check (result, "SET_EXPONENT");
8364 : }
8365 :
8366 :
8367 : gfc_expr *
8368 12371 : gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
8369 : {
8370 12371 : mpz_t shape[GFC_MAX_DIMENSIONS];
8371 12371 : gfc_expr *result, *e, *f;
8372 12371 : gfc_array_ref *ar;
8373 12371 : int n;
8374 12371 : bool t;
8375 12371 : int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
8376 :
8377 12371 : if (source->rank == -1)
8378 : return NULL;
8379 :
8380 11459 : result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
8381 11459 : result->shape = gfc_get_shape (1);
8382 11459 : mpz_init (result->shape[0]);
8383 :
8384 11459 : if (source->rank == 0)
8385 : return result;
8386 :
8387 11408 : if (source->expr_type == EXPR_VARIABLE)
8388 : {
8389 11160 : ar = gfc_find_array_ref (source);
8390 11160 : t = gfc_array_ref_shape (ar, shape);
8391 : }
8392 248 : else if (source->shape)
8393 : {
8394 73 : t = true;
8395 73 : for (n = 0; n < source->rank; n++)
8396 : {
8397 48 : mpz_init (shape[n]);
8398 48 : mpz_set (shape[n], source->shape[n]);
8399 : }
8400 : }
8401 : else
8402 : t = false;
8403 :
8404 18170 : for (n = 0; n < source->rank; n++)
8405 : {
8406 15740 : e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
8407 :
8408 15740 : if (t)
8409 6748 : mpz_set (e->value.integer, shape[n]);
8410 : else
8411 : {
8412 8992 : mpz_set_ui (e->value.integer, n + 1);
8413 :
8414 8992 : f = simplify_size (source, e, k);
8415 8992 : gfc_free_expr (e);
8416 8992 : if (f == NULL)
8417 : {
8418 8977 : gfc_free_expr (result);
8419 8977 : return NULL;
8420 : }
8421 : else
8422 : e = f;
8423 : }
8424 :
8425 6763 : if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
8426 : {
8427 1 : gfc_free_expr (result);
8428 1 : if (t)
8429 1 : gfc_clear_shape (shape, source->rank);
8430 : return &gfc_bad_expr;
8431 : }
8432 :
8433 6762 : gfc_constructor_append_expr (&result->value.constructor, e, NULL);
8434 : }
8435 :
8436 2430 : if (t)
8437 2430 : gfc_clear_shape (shape, source->rank);
8438 :
8439 2430 : mpz_set_si (result->shape[0], source->rank);
8440 :
8441 2430 : return result;
8442 : }
8443 :
8444 :
8445 : static gfc_expr *
8446 43021 : simplify_size (gfc_expr *array, gfc_expr *dim, int k)
8447 : {
8448 43021 : mpz_t size;
8449 43021 : gfc_expr *return_value;
8450 43021 : int d;
8451 43021 : gfc_ref *ref;
8452 :
8453 : /* For unary operations, the size of the result is given by the size
8454 : of the operand. For binary ones, it's the size of the first operand
8455 : unless it is scalar, then it is the size of the second. */
8456 43021 : if (array->expr_type == EXPR_OP && !array->value.op.uop)
8457 : {
8458 44 : gfc_expr* replacement;
8459 44 : gfc_expr* simplified;
8460 :
8461 44 : switch (array->value.op.op)
8462 : {
8463 : /* Unary operations. */
8464 7 : case INTRINSIC_NOT:
8465 7 : case INTRINSIC_UPLUS:
8466 7 : case INTRINSIC_UMINUS:
8467 7 : case INTRINSIC_PARENTHESES:
8468 7 : replacement = array->value.op.op1;
8469 7 : break;
8470 :
8471 : /* Binary operations. If any one of the operands is scalar, take
8472 : the other one's size. If both of them are arrays, it does not
8473 : matter -- try to find one with known shape, if possible. */
8474 37 : default:
8475 37 : if (array->value.op.op1->rank == 0)
8476 25 : replacement = array->value.op.op2;
8477 12 : else if (array->value.op.op2->rank == 0)
8478 : replacement = array->value.op.op1;
8479 : else
8480 : {
8481 0 : simplified = simplify_size (array->value.op.op1, dim, k);
8482 0 : if (simplified)
8483 : return simplified;
8484 :
8485 0 : replacement = array->value.op.op2;
8486 : }
8487 : break;
8488 : }
8489 :
8490 : /* Try to reduce it directly if possible. */
8491 44 : simplified = simplify_size (replacement, dim, k);
8492 :
8493 : /* Otherwise, we build a new SIZE call. This is hopefully at least
8494 : simpler than the original one. */
8495 44 : if (!simplified)
8496 : {
8497 20 : gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
8498 20 : simplified = gfc_build_intrinsic_call (gfc_current_ns,
8499 : GFC_ISYM_SIZE, "size",
8500 : array->where, 3,
8501 : gfc_copy_expr (replacement),
8502 : gfc_copy_expr (dim),
8503 : kind);
8504 : }
8505 : return simplified;
8506 : }
8507 :
8508 87126 : for (ref = array->ref; ref; ref = ref->next)
8509 40973 : if (ref->type == REF_ARRAY && ref->u.ar.as
8510 85126 : && !gfc_resolve_array_spec (ref->u.ar.as, 0))
8511 : return NULL;
8512 :
8513 42973 : if (dim == NULL)
8514 : {
8515 16672 : if (!gfc_array_size (array, &size))
8516 : return NULL;
8517 : }
8518 : else
8519 : {
8520 26301 : if (dim->expr_type != EXPR_CONSTANT)
8521 : return NULL;
8522 :
8523 25967 : if (array->rank == -1)
8524 : return NULL;
8525 :
8526 25253 : d = mpz_get_si (dim->value.integer) - 1;
8527 25253 : if (d < 0 || d > array->rank - 1)
8528 : {
8529 6 : gfc_error ("DIM argument (%d) to intrinsic SIZE at %L out of range "
8530 : "(1:%d)", d+1, &array->where, array->rank);
8531 6 : return &gfc_bad_expr;
8532 : }
8533 :
8534 25247 : if (!gfc_array_dimen_size (array, d, &size))
8535 : return NULL;
8536 : }
8537 :
8538 5006 : return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
8539 5006 : mpz_set (return_value->value.integer, size);
8540 5006 : mpz_clear (size);
8541 :
8542 5006 : return return_value;
8543 : }
8544 :
8545 :
8546 : gfc_expr *
8547 33203 : gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
8548 : {
8549 33203 : gfc_expr *result;
8550 33203 : int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
8551 :
8552 33203 : if (k == -1)
8553 : return &gfc_bad_expr;
8554 :
8555 33203 : result = simplify_size (array, dim, k);
8556 33203 : if (result == NULL || result == &gfc_bad_expr)
8557 : return result;
8558 :
8559 4604 : return range_check (result, "SIZE");
8560 : }
8561 :
8562 :
8563 : /* SIZEOF and C_SIZEOF return the size in bytes of an array element
8564 : multiplied by the array size. */
8565 :
8566 : gfc_expr *
8567 3435 : gfc_simplify_sizeof (gfc_expr *x)
8568 : {
8569 3435 : gfc_expr *result = NULL;
8570 3435 : mpz_t array_size;
8571 3435 : size_t res_size;
8572 :
8573 3435 : if (x->ts.type == BT_CLASS || x->ts.deferred)
8574 : return NULL;
8575 :
8576 2352 : if (x->ts.type == BT_CHARACTER
8577 249 : && (!x->ts.u.cl || !x->ts.u.cl->length
8578 75 : || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
8579 : return NULL;
8580 :
8581 2160 : if (x->rank && x->expr_type != EXPR_ARRAY)
8582 : {
8583 1394 : if (!gfc_array_size (x, &array_size))
8584 : return NULL;
8585 :
8586 174 : mpz_clear (array_size);
8587 : }
8588 :
8589 940 : result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
8590 : &x->where);
8591 940 : gfc_target_expr_size (x, &res_size);
8592 940 : mpz_set_si (result->value.integer, res_size);
8593 :
8594 940 : return result;
8595 : }
8596 :
8597 :
8598 : /* STORAGE_SIZE returns the size in bits of a single array element. */
8599 :
8600 : gfc_expr *
8601 1386 : gfc_simplify_storage_size (gfc_expr *x,
8602 : gfc_expr *kind)
8603 : {
8604 1386 : gfc_expr *result = NULL;
8605 1386 : int k;
8606 1386 : size_t siz;
8607 :
8608 1386 : if (x->ts.type == BT_CLASS || x->ts.deferred)
8609 : return NULL;
8610 :
8611 839 : if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
8612 297 : && (!x->ts.u.cl || !x->ts.u.cl->length
8613 96 : || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
8614 : return NULL;
8615 :
8616 638 : k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
8617 638 : if (k == -1)
8618 : return &gfc_bad_expr;
8619 :
8620 638 : result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
8621 :
8622 638 : gfc_element_size (x, &siz);
8623 638 : mpz_set_si (result->value.integer, siz);
8624 638 : mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
8625 :
8626 638 : return range_check (result, "STORAGE_SIZE");
8627 : }
8628 :
8629 :
8630 : gfc_expr *
8631 1365 : gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
8632 : {
8633 1365 : gfc_expr *result;
8634 :
8635 1365 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
8636 : return NULL;
8637 :
8638 95 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8639 :
8640 95 : switch (x->ts.type)
8641 : {
8642 22 : case BT_INTEGER:
8643 22 : mpz_abs (result->value.integer, x->value.integer);
8644 22 : if (mpz_sgn (y->value.integer) < 0)
8645 0 : mpz_neg (result->value.integer, result->value.integer);
8646 : break;
8647 :
8648 73 : case BT_REAL:
8649 73 : if (flag_sign_zero)
8650 61 : mpfr_copysign (result->value.real, x->value.real, y->value.real,
8651 : GFC_RND_MODE);
8652 : else
8653 24 : mpfr_setsign (result->value.real, x->value.real,
8654 : mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
8655 : break;
8656 :
8657 0 : default:
8658 0 : gfc_internal_error ("Bad type in gfc_simplify_sign");
8659 : }
8660 :
8661 : return result;
8662 : }
8663 :
8664 :
8665 : gfc_expr *
8666 849 : gfc_simplify_sin (gfc_expr *x)
8667 : {
8668 849 : gfc_expr *result;
8669 :
8670 849 : if (x->expr_type != EXPR_CONSTANT)
8671 : return NULL;
8672 :
8673 163 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8674 :
8675 163 : switch (x->ts.type)
8676 : {
8677 106 : case BT_REAL:
8678 106 : mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
8679 106 : break;
8680 :
8681 57 : case BT_COMPLEX:
8682 57 : gfc_set_model (x->value.real);
8683 57 : mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
8684 57 : break;
8685 :
8686 0 : default:
8687 0 : gfc_internal_error ("in gfc_simplify_sin(): Bad type");
8688 : }
8689 :
8690 163 : return range_check (result, "SIN");
8691 : }
8692 :
8693 :
8694 : gfc_expr *
8695 316 : gfc_simplify_sinh (gfc_expr *x)
8696 : {
8697 316 : gfc_expr *result;
8698 :
8699 316 : if (x->expr_type != EXPR_CONSTANT)
8700 : return NULL;
8701 :
8702 46 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8703 :
8704 46 : switch (x->ts.type)
8705 : {
8706 42 : case BT_REAL:
8707 42 : mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
8708 42 : break;
8709 :
8710 4 : case BT_COMPLEX:
8711 4 : mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
8712 4 : break;
8713 :
8714 0 : default:
8715 0 : gcc_unreachable ();
8716 : }
8717 :
8718 46 : return range_check (result, "SINH");
8719 : }
8720 :
8721 :
8722 : /* The argument is always a double precision real that is converted to
8723 : single precision. TODO: Rounding! */
8724 :
8725 : gfc_expr *
8726 3 : gfc_simplify_sngl (gfc_expr *a)
8727 : {
8728 3 : gfc_expr *result;
8729 3 : int tmp1, tmp2;
8730 :
8731 3 : if (a->expr_type != EXPR_CONSTANT)
8732 : return NULL;
8733 :
8734 : /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
8735 : warnings. */
8736 3 : tmp1 = warn_conversion;
8737 3 : tmp2 = warn_conversion_extra;
8738 3 : warn_conversion = warn_conversion_extra = 0;
8739 :
8740 3 : result = gfc_real2real (a, gfc_default_real_kind);
8741 :
8742 3 : warn_conversion = tmp1;
8743 3 : warn_conversion_extra = tmp2;
8744 :
8745 3 : return range_check (result, "SNGL");
8746 : }
8747 :
8748 :
8749 : gfc_expr *
8750 309 : gfc_simplify_spacing (gfc_expr *x)
8751 : {
8752 309 : gfc_expr *result;
8753 309 : int i;
8754 309 : long int en, ep;
8755 :
8756 309 : if (x->expr_type != EXPR_CONSTANT)
8757 : return NULL;
8758 :
8759 96 : i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
8760 96 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
8761 :
8762 : /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
8763 96 : if (mpfr_zero_p (x->value.real))
8764 : {
8765 12 : mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
8766 12 : return result;
8767 : }
8768 :
8769 : /* SPACING(inf) = NaN */
8770 84 : if (mpfr_inf_p (x->value.real))
8771 : {
8772 12 : mpfr_set_nan (result->value.real);
8773 12 : return result;
8774 : }
8775 :
8776 : /* SPACING(NaN) = same NaN */
8777 72 : if (mpfr_nan_p (x->value.real))
8778 : {
8779 6 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
8780 6 : return result;
8781 : }
8782 :
8783 : /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
8784 : are the radix, exponent of x, and precision. This excludes the
8785 : possibility of subnormal numbers. Fortran 2003 states the result is
8786 : b**max(e - p, emin - 1). */
8787 :
8788 66 : ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
8789 66 : en = (long int) gfc_real_kinds[i].min_exponent - 1;
8790 66 : en = en > ep ? en : ep;
8791 :
8792 66 : mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
8793 66 : mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
8794 :
8795 66 : return range_check (result, "SPACING");
8796 : }
8797 :
8798 :
8799 : gfc_expr *
8800 938 : gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
8801 : {
8802 938 : gfc_expr *result = NULL;
8803 938 : int nelem, i, j, dim, ncopies;
8804 938 : mpz_t size;
8805 :
8806 938 : if ((!gfc_is_constant_expr (source)
8807 825 : && !is_constant_array_expr (source))
8808 132 : || !gfc_is_constant_expr (dim_expr)
8809 1070 : || !gfc_is_constant_expr (ncopies_expr))
8810 : return NULL;
8811 :
8812 132 : gcc_assert (dim_expr->ts.type == BT_INTEGER);
8813 132 : gfc_extract_int (dim_expr, &dim);
8814 132 : dim -= 1; /* zero-base DIM */
8815 :
8816 132 : gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
8817 132 : gfc_extract_int (ncopies_expr, &ncopies);
8818 132 : ncopies = MAX (ncopies, 0);
8819 :
8820 : /* Do not allow the array size to exceed the limit for an array
8821 : constructor. */
8822 132 : if (source->expr_type == EXPR_ARRAY)
8823 : {
8824 37 : if (!gfc_array_size (source, &size))
8825 0 : gfc_internal_error ("Failure getting length of a constant array.");
8826 : }
8827 : else
8828 95 : mpz_init_set_ui (size, 1);
8829 :
8830 132 : nelem = mpz_get_si (size) * ncopies;
8831 132 : if (nelem > flag_max_array_constructor)
8832 : {
8833 3 : if (gfc_init_expr_flag)
8834 : {
8835 2 : gfc_error ("The number of elements (%d) in the array constructor "
8836 : "at %L requires an increase of the allowed %d upper "
8837 : "limit. See %<-fmax-array-constructor%> option.",
8838 : nelem, &source->where, flag_max_array_constructor);
8839 2 : return &gfc_bad_expr;
8840 : }
8841 : else
8842 : return NULL;
8843 : }
8844 :
8845 129 : if (source->expr_type == EXPR_CONSTANT
8846 40 : || source->expr_type == EXPR_STRUCTURE)
8847 : {
8848 95 : gcc_assert (dim == 0);
8849 :
8850 95 : result = gfc_get_array_expr (source->ts.type, source->ts.kind,
8851 : &source->where);
8852 95 : if (source->ts.type == BT_DERIVED)
8853 6 : result->ts.u.derived = source->ts.u.derived;
8854 95 : result->rank = 1;
8855 95 : result->shape = gfc_get_shape (result->rank);
8856 95 : mpz_init_set_si (result->shape[0], ncopies);
8857 :
8858 919 : for (i = 0; i < ncopies; ++i)
8859 729 : gfc_constructor_append_expr (&result->value.constructor,
8860 : gfc_copy_expr (source), NULL);
8861 : }
8862 34 : else if (source->expr_type == EXPR_ARRAY)
8863 : {
8864 34 : int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
8865 34 : gfc_constructor *source_ctor;
8866 :
8867 34 : gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
8868 34 : gcc_assert (dim >= 0 && dim <= source->rank);
8869 :
8870 34 : result = gfc_get_array_expr (source->ts.type, source->ts.kind,
8871 : &source->where);
8872 34 : if (source->ts.type == BT_DERIVED)
8873 1 : result->ts.u.derived = source->ts.u.derived;
8874 34 : result->rank = source->rank + 1;
8875 34 : result->shape = gfc_get_shape (result->rank);
8876 :
8877 120 : for (i = 0, j = 0; i < result->rank; ++i)
8878 : {
8879 86 : if (i != dim)
8880 52 : mpz_init_set (result->shape[i], source->shape[j++]);
8881 : else
8882 34 : mpz_init_set_si (result->shape[i], ncopies);
8883 :
8884 86 : extent[i] = mpz_get_si (result->shape[i]);
8885 86 : rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
8886 : }
8887 :
8888 34 : offset = 0;
8889 34 : for (source_ctor = gfc_constructor_first (source->value.constructor);
8890 242 : source_ctor; source_ctor = gfc_constructor_next (source_ctor))
8891 : {
8892 732 : for (i = 0; i < ncopies; ++i)
8893 524 : gfc_constructor_insert_expr (&result->value.constructor,
8894 : gfc_copy_expr (source_ctor->expr),
8895 524 : NULL, offset + i * rstride[dim]);
8896 :
8897 390 : offset += (dim == 0 ? ncopies : 1);
8898 : }
8899 : }
8900 : else
8901 : {
8902 0 : gfc_error ("Simplification of SPREAD at %C not yet implemented");
8903 0 : return &gfc_bad_expr;
8904 : }
8905 :
8906 129 : if (source->ts.type == BT_CHARACTER)
8907 20 : result->ts.u.cl = source->ts.u.cl;
8908 :
8909 : return result;
8910 : }
8911 :
8912 :
8913 : gfc_expr *
8914 1359 : gfc_simplify_sqrt (gfc_expr *e)
8915 : {
8916 1359 : gfc_expr *result = NULL;
8917 :
8918 1359 : if (e->expr_type != EXPR_CONSTANT)
8919 : return NULL;
8920 :
8921 221 : switch (e->ts.type)
8922 : {
8923 164 : case BT_REAL:
8924 164 : if (mpfr_cmp_si (e->value.real, 0) < 0)
8925 : {
8926 0 : gfc_error ("Argument of SQRT at %L has a negative value",
8927 : &e->where);
8928 0 : return &gfc_bad_expr;
8929 : }
8930 164 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
8931 164 : mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
8932 164 : break;
8933 :
8934 57 : case BT_COMPLEX:
8935 57 : gfc_set_model (e->value.real);
8936 :
8937 57 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
8938 57 : mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
8939 57 : break;
8940 :
8941 0 : default:
8942 0 : gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
8943 : }
8944 :
8945 221 : return range_check (result, "SQRT");
8946 : }
8947 :
8948 :
8949 : gfc_expr *
8950 4698 : gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
8951 : {
8952 4698 : return simplify_transformation (array, dim, mask, 0, gfc_add);
8953 : }
8954 :
8955 :
8956 : /* Simplify COTAN(X) where X has the unit of radian. */
8957 :
8958 : gfc_expr *
8959 230 : gfc_simplify_cotan (gfc_expr *x)
8960 : {
8961 230 : gfc_expr *result;
8962 230 : mpc_t swp, *val;
8963 :
8964 230 : if (x->expr_type != EXPR_CONSTANT)
8965 : return NULL;
8966 :
8967 26 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
8968 :
8969 26 : switch (x->ts.type)
8970 : {
8971 25 : case BT_REAL:
8972 25 : mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE);
8973 25 : break;
8974 :
8975 1 : case BT_COMPLEX:
8976 : /* There is no builtin mpc_cot, so compute cot = cos / sin. */
8977 1 : val = &result->value.complex;
8978 1 : mpc_init2 (swp, mpfr_get_default_prec ());
8979 1 : mpc_sin_cos (*val, swp, x->value.complex, GFC_MPC_RND_MODE,
8980 : GFC_MPC_RND_MODE);
8981 1 : mpc_div (*val, swp, *val, GFC_MPC_RND_MODE);
8982 1 : mpc_clear (swp);
8983 1 : break;
8984 :
8985 0 : default:
8986 0 : gcc_unreachable ();
8987 : }
8988 :
8989 26 : return range_check (result, "COTAN");
8990 : }
8991 :
8992 :
8993 : gfc_expr *
8994 586 : gfc_simplify_tan (gfc_expr *x)
8995 : {
8996 586 : gfc_expr *result;
8997 :
8998 586 : if (x->expr_type != EXPR_CONSTANT)
8999 : return NULL;
9000 :
9001 46 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
9002 :
9003 46 : switch (x->ts.type)
9004 : {
9005 42 : case BT_REAL:
9006 42 : mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
9007 42 : break;
9008 :
9009 4 : case BT_COMPLEX:
9010 4 : mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
9011 4 : break;
9012 :
9013 0 : default:
9014 0 : gcc_unreachable ();
9015 : }
9016 :
9017 46 : return range_check (result, "TAN");
9018 : }
9019 :
9020 :
9021 : gfc_expr *
9022 316 : gfc_simplify_tanh (gfc_expr *x)
9023 : {
9024 316 : gfc_expr *result;
9025 :
9026 316 : if (x->expr_type != EXPR_CONSTANT)
9027 : return NULL;
9028 :
9029 46 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
9030 :
9031 46 : switch (x->ts.type)
9032 : {
9033 42 : case BT_REAL:
9034 42 : mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
9035 42 : break;
9036 :
9037 4 : case BT_COMPLEX:
9038 4 : mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
9039 4 : break;
9040 :
9041 0 : default:
9042 0 : gcc_unreachable ();
9043 : }
9044 :
9045 46 : return range_check (result, "TANH");
9046 : }
9047 :
9048 :
9049 : gfc_expr *
9050 852 : gfc_simplify_tiny (gfc_expr *e)
9051 : {
9052 852 : gfc_expr *result;
9053 852 : int i;
9054 :
9055 852 : i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
9056 :
9057 852 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
9058 852 : mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
9059 :
9060 852 : return result;
9061 : }
9062 :
9063 :
9064 : gfc_expr *
9065 1104 : gfc_simplify_trailz (gfc_expr *e)
9066 : {
9067 1104 : unsigned long tz, bs;
9068 1104 : int i;
9069 :
9070 1104 : if (e->expr_type != EXPR_CONSTANT)
9071 : return NULL;
9072 :
9073 258 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
9074 258 : bs = gfc_integer_kinds[i].bit_size;
9075 258 : tz = mpz_scan1 (e->value.integer, 0);
9076 :
9077 258 : return gfc_get_int_expr (gfc_default_integer_kind,
9078 258 : &e->where, MIN (tz, bs));
9079 : }
9080 :
9081 :
9082 : gfc_expr *
9083 2967 : gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
9084 : {
9085 2967 : gfc_expr *result;
9086 2967 : gfc_expr *mold_element;
9087 2967 : size_t source_size;
9088 2967 : size_t result_size;
9089 2967 : size_t buffer_size;
9090 2967 : mpz_t tmp;
9091 2967 : unsigned char *buffer;
9092 2967 : size_t result_length;
9093 :
9094 2967 : if (!gfc_is_constant_expr (source) || !gfc_is_constant_expr (size))
9095 : return NULL;
9096 :
9097 940 : if (!gfc_resolve_expr (mold))
9098 : return NULL;
9099 940 : if (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
9100 : return NULL;
9101 :
9102 894 : if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
9103 : &result_size, &result_length))
9104 : return NULL;
9105 :
9106 : /* Calculate the size of the source. */
9107 860 : if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp))
9108 0 : gfc_internal_error ("Failure getting length of a constant array.");
9109 :
9110 : /* Create an empty new expression with the appropriate characteristics. */
9111 860 : result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
9112 : &source->where);
9113 860 : result->ts = mold->ts;
9114 :
9115 336 : mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor)
9116 1019 : ? gfc_constructor_first (mold->value.constructor)->expr
9117 : : mold;
9118 :
9119 : /* Set result character length, if needed. Note that this needs to be
9120 : set even for array expressions, in order to pass this information into
9121 : gfc_target_interpret_expr. */
9122 860 : if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
9123 : {
9124 341 : result->value.character.length = mold_element->value.character.length;
9125 :
9126 : /* Let the typespec of the result inherit the string length.
9127 : This is crucial if a resulting array has size zero. */
9128 341 : if (mold_element->ts.u.cl->length)
9129 230 : result->ts.u.cl->length = gfc_copy_expr (mold_element->ts.u.cl->length);
9130 : else
9131 111 : result->ts.u.cl->length =
9132 111 : gfc_get_int_expr (gfc_charlen_int_kind, NULL,
9133 : mold_element->value.character.length);
9134 : }
9135 :
9136 : /* Set the number of elements in the result, and determine its size. */
9137 :
9138 860 : if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
9139 : {
9140 273 : result->expr_type = EXPR_ARRAY;
9141 273 : result->rank = 1;
9142 273 : result->shape = gfc_get_shape (1);
9143 273 : mpz_init_set_ui (result->shape[0], result_length);
9144 : }
9145 : else
9146 587 : result->rank = 0;
9147 :
9148 : /* Allocate the buffer to store the binary version of the source. */
9149 860 : buffer_size = MAX (source_size, result_size);
9150 860 : buffer = (unsigned char*)alloca (buffer_size);
9151 860 : memset (buffer, 0, buffer_size);
9152 :
9153 : /* Now write source to the buffer. */
9154 860 : gfc_target_encode_expr (source, buffer, buffer_size);
9155 :
9156 : /* And read the buffer back into the new expression. */
9157 860 : gfc_target_interpret_expr (buffer, buffer_size, result, false);
9158 :
9159 860 : return result;
9160 : }
9161 :
9162 :
9163 : gfc_expr *
9164 1703 : gfc_simplify_transpose (gfc_expr *matrix)
9165 : {
9166 1703 : int row, matrix_rows, col, matrix_cols;
9167 1703 : gfc_expr *result;
9168 :
9169 1703 : if (!is_constant_array_expr (matrix))
9170 : return NULL;
9171 :
9172 45 : gcc_assert (matrix->rank == 2);
9173 :
9174 45 : if (matrix->shape == NULL)
9175 : return NULL;
9176 :
9177 45 : result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
9178 : &matrix->where);
9179 45 : result->rank = 2;
9180 45 : result->shape = gfc_get_shape (result->rank);
9181 45 : mpz_init_set (result->shape[0], matrix->shape[1]);
9182 45 : mpz_init_set (result->shape[1], matrix->shape[0]);
9183 :
9184 45 : if (matrix->ts.type == BT_CHARACTER)
9185 18 : result->ts.u.cl = matrix->ts.u.cl;
9186 27 : else if (matrix->ts.type == BT_DERIVED)
9187 7 : result->ts.u.derived = matrix->ts.u.derived;
9188 :
9189 45 : matrix_rows = mpz_get_si (matrix->shape[0]);
9190 45 : matrix_cols = mpz_get_si (matrix->shape[1]);
9191 201 : for (row = 0; row < matrix_rows; ++row)
9192 530 : for (col = 0; col < matrix_cols; ++col)
9193 : {
9194 748 : gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
9195 374 : col * matrix_rows + row);
9196 374 : gfc_constructor_insert_expr (&result->value.constructor,
9197 : gfc_copy_expr (e), &matrix->where,
9198 374 : row * matrix_cols + col);
9199 : }
9200 :
9201 : return result;
9202 : }
9203 :
9204 :
9205 : gfc_expr *
9206 4651 : gfc_simplify_trim (gfc_expr *e)
9207 : {
9208 4651 : gfc_expr *result;
9209 4651 : int count, i, len, lentrim;
9210 :
9211 4651 : if (e->expr_type != EXPR_CONSTANT)
9212 : return NULL;
9213 :
9214 44 : len = e->value.character.length;
9215 196 : for (count = 0, i = 1; i <= len; ++i)
9216 : {
9217 196 : if (e->value.character.string[len - i] == ' ')
9218 152 : count++;
9219 : else
9220 : break;
9221 : }
9222 :
9223 44 : lentrim = len - count;
9224 :
9225 44 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
9226 769 : for (i = 0; i < lentrim; i++)
9227 681 : result->value.character.string[i] = e->value.character.string[i];
9228 :
9229 : return result;
9230 : }
9231 :
9232 :
9233 : gfc_expr *
9234 407 : gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub,
9235 : gfc_expr *team ATTRIBUTE_UNUSED,
9236 : gfc_expr *team_number ATTRIBUTE_UNUSED)
9237 : {
9238 407 : gfc_expr *result;
9239 407 : gfc_ref *ref;
9240 407 : gfc_array_spec *as;
9241 407 : gfc_constructor *sub_cons;
9242 407 : bool first_image;
9243 407 : int d;
9244 :
9245 407 : if (!is_constant_array_expr (sub))
9246 : return NULL;
9247 :
9248 : /* Follow any component references. */
9249 291 : as = coarray->symtree->n.sym->as;
9250 596 : for (ref = coarray->ref; ref; ref = ref->next)
9251 305 : if (ref->type == REF_COMPONENT)
9252 8 : as = ref->u.ar.as;
9253 :
9254 291 : if (!as || as->type == AS_DEFERRED)
9255 : return NULL;
9256 :
9257 : /* "valid sequence of cosubscripts" are required; thus, return 0 unless
9258 : the cosubscript addresses the first image. */
9259 :
9260 166 : sub_cons = gfc_constructor_first (sub->value.constructor);
9261 166 : first_image = true;
9262 :
9263 531 : for (d = 1; d <= as->corank; d++)
9264 : {
9265 255 : gfc_expr *ca_bound;
9266 255 : int cmp;
9267 :
9268 255 : gcc_assert (sub_cons != NULL);
9269 :
9270 255 : ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
9271 : NULL, true);
9272 255 : if (ca_bound == NULL)
9273 : return NULL;
9274 :
9275 201 : if (ca_bound == &gfc_bad_expr)
9276 : return ca_bound;
9277 :
9278 201 : cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
9279 :
9280 201 : if (cmp == 0)
9281 : {
9282 139 : gfc_free_expr (ca_bound);
9283 139 : sub_cons = gfc_constructor_next (sub_cons);
9284 139 : continue;
9285 : }
9286 :
9287 62 : first_image = false;
9288 :
9289 62 : if (cmp > 0)
9290 : {
9291 1 : gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
9292 : "SUB has %ld and COARRAY lower bound is %ld)",
9293 : &coarray->where, d,
9294 : mpz_get_si (sub_cons->expr->value.integer),
9295 : mpz_get_si (ca_bound->value.integer));
9296 1 : gfc_free_expr (ca_bound);
9297 1 : return &gfc_bad_expr;
9298 : }
9299 :
9300 61 : gfc_free_expr (ca_bound);
9301 :
9302 : /* Check whether upperbound is valid for the multi-images case. */
9303 61 : if (d < as->corank)
9304 : {
9305 27 : ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
9306 : NULL, true);
9307 27 : if (ca_bound == &gfc_bad_expr)
9308 : return ca_bound;
9309 :
9310 27 : if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
9311 27 : && mpz_cmp (ca_bound->value.integer,
9312 27 : sub_cons->expr->value.integer) < 0)
9313 : {
9314 1 : gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
9315 : "SUB has %ld and COARRAY upper bound is %ld)",
9316 : &coarray->where, d,
9317 : mpz_get_si (sub_cons->expr->value.integer),
9318 : mpz_get_si (ca_bound->value.integer));
9319 1 : gfc_free_expr (ca_bound);
9320 1 : return &gfc_bad_expr;
9321 : }
9322 :
9323 : if (ca_bound)
9324 26 : gfc_free_expr (ca_bound);
9325 : }
9326 :
9327 60 : sub_cons = gfc_constructor_next (sub_cons);
9328 : }
9329 :
9330 110 : gcc_assert (sub_cons == NULL);
9331 :
9332 110 : if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image)
9333 : return NULL;
9334 :
9335 88 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
9336 : &gfc_current_locus);
9337 88 : if (first_image)
9338 55 : mpz_set_si (result->value.integer, 1);
9339 : else
9340 33 : mpz_set_si (result->value.integer, 0);
9341 :
9342 : return result;
9343 : }
9344 :
9345 : gfc_expr *
9346 133 : gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED)
9347 : {
9348 133 : if (flag_coarray == GFC_FCOARRAY_NONE)
9349 : {
9350 0 : gfc_current_locus = *gfc_current_intrinsic_where;
9351 0 : gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
9352 : return &gfc_bad_expr;
9353 : }
9354 :
9355 : /* Simplification is possible for fcoarray = single only. For all other modes
9356 : the result depends on runtime conditions. */
9357 133 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
9358 : return NULL;
9359 :
9360 20 : if (gfc_is_constant_expr (image))
9361 : {
9362 9 : gfc_expr *result;
9363 9 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
9364 : &image->where);
9365 9 : if (mpz_get_si (image->value.integer) == 1)
9366 4 : mpz_set_si (result->value.integer, 0);
9367 : else
9368 5 : mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE);
9369 : return result;
9370 : }
9371 : else
9372 : return NULL;
9373 : }
9374 :
9375 :
9376 : gfc_expr *
9377 3792 : gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
9378 : gfc_expr *team ATTRIBUTE_UNUSED)
9379 : {
9380 3792 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
9381 : return NULL;
9382 :
9383 : /* If no coarray argument has been passed. */
9384 1130 : if (coarray == NULL)
9385 : {
9386 616 : gfc_expr *result;
9387 : /* FIXME: gfc_current_locus is wrong. */
9388 616 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
9389 : &gfc_current_locus);
9390 616 : mpz_set_si (result->value.integer, 1);
9391 616 : return result;
9392 : }
9393 :
9394 : /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
9395 514 : return simplify_cobound (coarray, dim, NULL, 0);
9396 : }
9397 :
9398 :
9399 : gfc_expr *
9400 15284 : gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
9401 : {
9402 15284 : return simplify_bound (array, dim, kind, 1);
9403 : }
9404 :
9405 : gfc_expr *
9406 656 : gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
9407 : {
9408 656 : return simplify_cobound (array, dim, kind, 1);
9409 : }
9410 :
9411 :
9412 : gfc_expr *
9413 480 : gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
9414 : {
9415 480 : gfc_expr *result, *e;
9416 480 : gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
9417 :
9418 480 : if (!is_constant_array_expr (vector)
9419 242 : || !is_constant_array_expr (mask)
9420 503 : || (!gfc_is_constant_expr (field)
9421 12 : && !is_constant_array_expr (field)))
9422 : return NULL;
9423 :
9424 23 : result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
9425 : &vector->where);
9426 23 : if (vector->ts.type == BT_DERIVED)
9427 4 : result->ts.u.derived = vector->ts.u.derived;
9428 23 : result->rank = mask->rank;
9429 23 : result->shape = gfc_copy_shape (mask->shape, mask->rank);
9430 :
9431 23 : if (vector->ts.type == BT_CHARACTER)
9432 0 : result->ts.u.cl = vector->ts.u.cl;
9433 :
9434 23 : vector_ctor = gfc_constructor_first (vector->value.constructor);
9435 23 : mask_ctor = gfc_constructor_first (mask->value.constructor);
9436 23 : field_ctor
9437 23 : = field->expr_type == EXPR_ARRAY
9438 23 : ? gfc_constructor_first (field->value.constructor)
9439 : : NULL;
9440 :
9441 168 : while (mask_ctor)
9442 : {
9443 151 : if (mask_ctor->expr->value.logical)
9444 : {
9445 55 : if (vector_ctor)
9446 : {
9447 52 : e = gfc_copy_expr (vector_ctor->expr);
9448 52 : vector_ctor = gfc_constructor_next (vector_ctor);
9449 : }
9450 : else
9451 : {
9452 3 : gfc_free_expr (result);
9453 3 : return NULL;
9454 : }
9455 : }
9456 96 : else if (field->expr_type == EXPR_ARRAY)
9457 : {
9458 52 : if (field_ctor)
9459 49 : e = gfc_copy_expr (field_ctor->expr);
9460 : else
9461 : {
9462 : /* Not enough elements in array FIELD. */
9463 3 : gfc_free_expr (result);
9464 3 : return &gfc_bad_expr;
9465 : }
9466 : }
9467 : else
9468 44 : e = gfc_copy_expr (field);
9469 :
9470 145 : gfc_constructor_append_expr (&result->value.constructor, e, NULL);
9471 :
9472 145 : mask_ctor = gfc_constructor_next (mask_ctor);
9473 145 : field_ctor = gfc_constructor_next (field_ctor);
9474 : }
9475 :
9476 : return result;
9477 : }
9478 :
9479 :
9480 : gfc_expr *
9481 410 : gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
9482 : {
9483 410 : gfc_expr *result;
9484 410 : int back;
9485 410 : size_t index, len, lenset;
9486 410 : size_t i;
9487 410 : int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
9488 :
9489 410 : if (k == -1)
9490 : return &gfc_bad_expr;
9491 :
9492 410 : if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
9493 158 : || ( b != NULL && b->expr_type != EXPR_CONSTANT))
9494 : return NULL;
9495 :
9496 150 : if (b != NULL && b->value.logical != 0)
9497 : back = 1;
9498 : else
9499 78 : back = 0;
9500 :
9501 156 : result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
9502 :
9503 156 : len = s->value.character.length;
9504 156 : lenset = set->value.character.length;
9505 :
9506 156 : if (len == 0)
9507 : {
9508 0 : mpz_set_ui (result->value.integer, 0);
9509 0 : return result;
9510 : }
9511 :
9512 156 : if (back == 0)
9513 : {
9514 78 : if (lenset == 0)
9515 : {
9516 18 : mpz_set_ui (result->value.integer, 1);
9517 18 : return result;
9518 : }
9519 :
9520 60 : index = wide_strspn (s->value.character.string,
9521 60 : set->value.character.string) + 1;
9522 60 : if (index > len)
9523 0 : index = 0;
9524 :
9525 : }
9526 : else
9527 : {
9528 78 : if (lenset == 0)
9529 : {
9530 18 : mpz_set_ui (result->value.integer, len);
9531 18 : return result;
9532 : }
9533 96 : for (index = len; index > 0; index --)
9534 : {
9535 300 : for (i = 0; i < lenset; i++)
9536 : {
9537 240 : if (s->value.character.string[index - 1]
9538 240 : == set->value.character.string[i])
9539 : break;
9540 : }
9541 96 : if (i == lenset)
9542 : break;
9543 : }
9544 : }
9545 :
9546 120 : mpz_set_ui (result->value.integer, index);
9547 120 : return result;
9548 : }
9549 :
9550 :
9551 : gfc_expr *
9552 26 : gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
9553 : {
9554 26 : gfc_expr *result;
9555 26 : int kind;
9556 :
9557 26 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
9558 : return NULL;
9559 :
9560 6 : kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
9561 :
9562 6 : switch (x->ts.type)
9563 : {
9564 0 : case BT_INTEGER:
9565 0 : result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
9566 0 : mpz_xor (result->value.integer, x->value.integer, y->value.integer);
9567 0 : return range_check (result, "XOR");
9568 :
9569 6 : case BT_LOGICAL:
9570 6 : return gfc_get_logical_expr (kind, &x->where,
9571 6 : (x->value.logical && !y->value.logical)
9572 6 : || (!x->value.logical && y->value.logical));
9573 :
9574 0 : default:
9575 0 : gcc_unreachable ();
9576 : }
9577 : }
9578 :
9579 :
9580 : /****************** Constant simplification *****************/
9581 :
9582 : /* Master function to convert one constant to another. While this is
9583 : used as a simplification function, it requires the destination type
9584 : and kind information which is supplied by a special case in
9585 : do_simplify(). */
9586 :
9587 : gfc_expr *
9588 175832 : gfc_convert_constant (gfc_expr *e, bt type, int kind)
9589 : {
9590 175832 : gfc_expr *result, *(*f) (gfc_expr *, int);
9591 175832 : gfc_constructor *c, *t;
9592 :
9593 175832 : switch (e->ts.type)
9594 : {
9595 154432 : case BT_INTEGER:
9596 154432 : switch (type)
9597 : {
9598 : case BT_INTEGER:
9599 : f = gfc_int2int;
9600 : break;
9601 152 : case BT_UNSIGNED:
9602 152 : f = gfc_int2uint;
9603 152 : break;
9604 64293 : case BT_REAL:
9605 64293 : f = gfc_int2real;
9606 64293 : break;
9607 1454 : case BT_COMPLEX:
9608 1454 : f = gfc_int2complex;
9609 1454 : break;
9610 0 : case BT_LOGICAL:
9611 0 : f = gfc_int2log;
9612 0 : break;
9613 0 : default:
9614 0 : goto oops;
9615 : }
9616 : break;
9617 :
9618 596 : case BT_UNSIGNED:
9619 596 : switch (type)
9620 : {
9621 : case BT_INTEGER:
9622 : f = gfc_uint2int;
9623 : break;
9624 223 : case BT_UNSIGNED:
9625 223 : f = gfc_uint2uint;
9626 223 : break;
9627 48 : case BT_REAL:
9628 48 : f = gfc_uint2real;
9629 48 : break;
9630 0 : case BT_COMPLEX:
9631 0 : f = gfc_uint2complex;
9632 0 : break;
9633 0 : case BT_LOGICAL:
9634 0 : f = gfc_uint2log;
9635 0 : break;
9636 0 : default:
9637 0 : goto oops;
9638 : }
9639 : break;
9640 :
9641 13777 : case BT_REAL:
9642 13777 : switch (type)
9643 : {
9644 : case BT_INTEGER:
9645 : f = gfc_real2int;
9646 : break;
9647 6 : case BT_UNSIGNED:
9648 6 : f = gfc_real2uint;
9649 6 : break;
9650 10550 : case BT_REAL:
9651 10550 : f = gfc_real2real;
9652 10550 : break;
9653 2017 : case BT_COMPLEX:
9654 2017 : f = gfc_real2complex;
9655 2017 : break;
9656 0 : default:
9657 0 : goto oops;
9658 : }
9659 : break;
9660 :
9661 2914 : case BT_COMPLEX:
9662 2914 : switch (type)
9663 : {
9664 : case BT_INTEGER:
9665 : f = gfc_complex2int;
9666 : break;
9667 6 : case BT_UNSIGNED:
9668 6 : f = gfc_complex2uint;
9669 6 : break;
9670 204 : case BT_REAL:
9671 204 : f = gfc_complex2real;
9672 204 : break;
9673 2648 : case BT_COMPLEX:
9674 2648 : f = gfc_complex2complex;
9675 2648 : break;
9676 :
9677 0 : default:
9678 0 : goto oops;
9679 : }
9680 : break;
9681 :
9682 2023 : case BT_LOGICAL:
9683 2023 : switch (type)
9684 : {
9685 : case BT_INTEGER:
9686 : f = gfc_log2int;
9687 : break;
9688 0 : case BT_UNSIGNED:
9689 0 : f = gfc_log2uint;
9690 0 : break;
9691 1793 : case BT_LOGICAL:
9692 1793 : f = gfc_log2log;
9693 1793 : break;
9694 0 : default:
9695 0 : goto oops;
9696 : }
9697 : break;
9698 :
9699 1330 : case BT_HOLLERITH:
9700 1330 : switch (type)
9701 : {
9702 : case BT_INTEGER:
9703 : f = gfc_hollerith2int;
9704 : break;
9705 :
9706 : /* Hollerith is for legacy code, we do not currently support
9707 : converting this to UNSIGNED. */
9708 0 : case BT_UNSIGNED:
9709 0 : goto oops;
9710 :
9711 327 : case BT_REAL:
9712 327 : f = gfc_hollerith2real;
9713 327 : break;
9714 :
9715 288 : case BT_COMPLEX:
9716 288 : f = gfc_hollerith2complex;
9717 288 : break;
9718 :
9719 146 : case BT_CHARACTER:
9720 146 : f = gfc_hollerith2character;
9721 146 : break;
9722 :
9723 195 : case BT_LOGICAL:
9724 195 : f = gfc_hollerith2logical;
9725 195 : break;
9726 :
9727 0 : default:
9728 0 : goto oops;
9729 : }
9730 : break;
9731 :
9732 747 : case BT_CHARACTER:
9733 747 : switch (type)
9734 : {
9735 : case BT_INTEGER:
9736 : f = gfc_character2int;
9737 : break;
9738 :
9739 0 : case BT_UNSIGNED:
9740 0 : goto oops;
9741 :
9742 187 : case BT_REAL:
9743 187 : f = gfc_character2real;
9744 187 : break;
9745 :
9746 187 : case BT_COMPLEX:
9747 187 : f = gfc_character2complex;
9748 187 : break;
9749 :
9750 0 : case BT_CHARACTER:
9751 0 : f = gfc_character2character;
9752 0 : break;
9753 :
9754 186 : case BT_LOGICAL:
9755 186 : f = gfc_character2logical;
9756 186 : break;
9757 :
9758 0 : default:
9759 0 : goto oops;
9760 : }
9761 : break;
9762 :
9763 : default:
9764 175832 : oops:
9765 : return &gfc_bad_expr;
9766 : }
9767 :
9768 175819 : result = NULL;
9769 :
9770 175819 : switch (e->expr_type)
9771 : {
9772 130548 : case EXPR_CONSTANT:
9773 130548 : result = f (e, kind);
9774 130548 : if (result == NULL)
9775 6 : return &gfc_bad_expr;
9776 : break;
9777 :
9778 5039 : case EXPR_ARRAY:
9779 5039 : if (!gfc_is_constant_expr (e))
9780 : break;
9781 :
9782 4865 : result = gfc_get_array_expr (type, kind, &e->where);
9783 4865 : result->shape = gfc_copy_shape (e->shape, e->rank);
9784 4865 : result->rank = e->rank;
9785 :
9786 4865 : for (c = gfc_constructor_first (e->value.constructor);
9787 60461 : c; c = gfc_constructor_next (c))
9788 : {
9789 55633 : gfc_expr *tmp;
9790 55633 : if (c->iterator == NULL)
9791 : {
9792 55610 : if (c->expr->expr_type == EXPR_ARRAY)
9793 69 : tmp = gfc_convert_constant (c->expr, type, kind);
9794 55541 : else if (c->expr->expr_type == EXPR_OP)
9795 : {
9796 29 : if (!gfc_simplify_expr (c->expr, 1))
9797 : return &gfc_bad_expr;
9798 29 : tmp = f (c->expr, kind);
9799 : }
9800 : else
9801 55512 : tmp = f (c->expr, kind);
9802 : }
9803 : else
9804 23 : tmp = gfc_convert_constant (c->expr, type, kind);
9805 :
9806 55633 : if (tmp == NULL || tmp == &gfc_bad_expr)
9807 : {
9808 37 : gfc_free_expr (result);
9809 37 : return NULL;
9810 : }
9811 :
9812 55596 : t = gfc_constructor_append_expr (&result->value.constructor,
9813 : tmp, &c->where);
9814 55596 : if (c->iterator)
9815 4 : t->iterator = gfc_copy_iterator (c->iterator);
9816 : }
9817 :
9818 : break;
9819 :
9820 : default:
9821 : break;
9822 : }
9823 :
9824 : return result;
9825 : }
9826 :
9827 :
9828 : /* Function for converting character constants. */
9829 : gfc_expr *
9830 256 : gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
9831 : {
9832 256 : gfc_expr *result;
9833 256 : int i;
9834 :
9835 256 : if (!gfc_is_constant_expr (e))
9836 : return NULL;
9837 :
9838 256 : if (e->expr_type == EXPR_CONSTANT)
9839 : {
9840 : /* Simple case of a scalar. */
9841 237 : result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
9842 237 : if (result == NULL)
9843 : return &gfc_bad_expr;
9844 :
9845 237 : result->value.character.length = e->value.character.length;
9846 237 : result->value.character.string
9847 237 : = gfc_get_wide_string (e->value.character.length + 1);
9848 237 : memcpy (result->value.character.string, e->value.character.string,
9849 237 : (e->value.character.length + 1) * sizeof (gfc_char_t));
9850 :
9851 : /* Check we only have values representable in the destination kind. */
9852 1285 : for (i = 0; i < result->value.character.length; i++)
9853 1052 : if (!gfc_check_character_range (result->value.character.string[i],
9854 : kind))
9855 : {
9856 4 : gfc_error ("Character %qs in string at %L cannot be converted "
9857 : "into character kind %d",
9858 4 : gfc_print_wide_char (result->value.character.string[i]),
9859 : &e->where, kind);
9860 4 : gfc_free_expr (result);
9861 4 : return &gfc_bad_expr;
9862 : }
9863 :
9864 : return result;
9865 : }
9866 19 : else if (e->expr_type == EXPR_ARRAY)
9867 : {
9868 : /* For an array constructor, we convert each constructor element. */
9869 19 : gfc_constructor *c;
9870 :
9871 19 : result = gfc_get_array_expr (type, kind, &e->where);
9872 19 : result->shape = gfc_copy_shape (e->shape, e->rank);
9873 19 : result->rank = e->rank;
9874 19 : result->ts.u.cl = e->ts.u.cl;
9875 :
9876 19 : for (c = gfc_constructor_first (e->value.constructor);
9877 76 : c; c = gfc_constructor_next (c))
9878 : {
9879 57 : gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
9880 57 : if (tmp == &gfc_bad_expr)
9881 : {
9882 0 : gfc_free_expr (result);
9883 0 : return &gfc_bad_expr;
9884 : }
9885 :
9886 57 : if (tmp == NULL)
9887 : {
9888 0 : gfc_free_expr (result);
9889 0 : return NULL;
9890 : }
9891 :
9892 57 : gfc_constructor_append_expr (&result->value.constructor,
9893 : tmp, &c->where);
9894 : }
9895 :
9896 : return result;
9897 : }
9898 : else
9899 : return NULL;
9900 : }
9901 :
9902 :
9903 : gfc_expr *
9904 8 : gfc_simplify_compiler_options (void)
9905 : {
9906 8 : char *str;
9907 8 : gfc_expr *result;
9908 :
9909 8 : str = gfc_get_option_string ();
9910 16 : result = gfc_get_character_expr (gfc_default_character_kind,
9911 8 : &gfc_current_locus, str, strlen (str));
9912 8 : free (str);
9913 8 : return result;
9914 : }
9915 :
9916 :
9917 : gfc_expr *
9918 10 : gfc_simplify_compiler_version (void)
9919 : {
9920 10 : char *buffer;
9921 10 : size_t len;
9922 :
9923 10 : len = strlen ("GCC version ") + strlen (version_string);
9924 10 : buffer = XALLOCAVEC (char, len + 1);
9925 10 : snprintf (buffer, len + 1, "GCC version %s", version_string);
9926 10 : return gfc_get_character_expr (gfc_default_character_kind,
9927 10 : &gfc_current_locus, buffer, len);
9928 : }
9929 :
9930 : /* Simplification routines for intrinsics of IEEE modules. */
9931 :
9932 : gfc_expr *
9933 243 : simplify_ieee_selected_real_kind (gfc_expr *expr)
9934 : {
9935 243 : gfc_actual_arglist *arg;
9936 243 : gfc_expr *p = NULL, *q = NULL, *rdx = NULL;
9937 :
9938 243 : arg = expr->value.function.actual;
9939 243 : p = arg->expr;
9940 243 : if (arg->next)
9941 : {
9942 241 : q = arg->next->expr;
9943 241 : if (arg->next->next)
9944 241 : rdx = arg->next->next->expr;
9945 : }
9946 :
9947 : /* Currently, if IEEE is supported and this module is built, it means
9948 : all our floating-point types conform to IEEE. Hence, we simply handle
9949 : IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
9950 243 : return gfc_simplify_selected_real_kind (p, q, rdx);
9951 : }
9952 :
9953 : gfc_expr *
9954 102 : simplify_ieee_support (gfc_expr *expr)
9955 : {
9956 : /* We consider that if the IEEE modules are loaded, we have full support
9957 : for flags, halting and rounding, which are the three functions
9958 : (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
9959 : expressions. One day, we will need libgfortran to detect support and
9960 : communicate it back to us, allowing for partial support. */
9961 :
9962 102 : return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where,
9963 102 : true);
9964 : }
9965 :
9966 : bool
9967 993 : matches_ieee_function_name (gfc_symbol *sym, const char *name)
9968 : {
9969 993 : int n = strlen(name);
9970 :
9971 993 : if (!strncmp(sym->name, name, n))
9972 : return true;
9973 :
9974 : /* If a generic was used and renamed, we need more work to find out.
9975 : Compare the specific name. */
9976 654 : if (sym->generic && !strncmp(sym->generic->sym->name, name, n))
9977 6 : return true;
9978 :
9979 : return false;
9980 : }
9981 :
9982 : gfc_expr *
9983 453 : gfc_simplify_ieee_functions (gfc_expr *expr)
9984 : {
9985 453 : gfc_symbol* sym = expr->symtree->n.sym;
9986 :
9987 453 : if (matches_ieee_function_name(sym, "ieee_selected_real_kind"))
9988 243 : return simplify_ieee_selected_real_kind (expr);
9989 210 : else if (matches_ieee_function_name(sym, "ieee_support_flag")
9990 174 : || matches_ieee_function_name(sym, "ieee_support_halting")
9991 366 : || matches_ieee_function_name(sym, "ieee_support_rounding"))
9992 102 : return simplify_ieee_support (expr);
9993 : else
9994 : return NULL;
9995 : }
|
