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