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