Branch data Line data Source code
1 : : /* Simplify intrinsic functions at compile-time.
2 : : Copyright (C) 2000-2024 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 : 333548 : range_check (gfc_expr *result, const char *name)
79 : : {
80 : 333548 : if (result == NULL)
81 : : return &gfc_bad_expr;
82 : :
83 : 333548 : if (result->expr_type != EXPR_CONSTANT)
84 : : return result;
85 : :
86 : 333528 : 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 : 135417 : get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
121 : : {
122 : 135417 : int kind;
123 : :
124 : 135417 : if (k == NULL)
125 : : return default_kind;
126 : :
127 : 29762 : if (k->expr_type != EXPR_CONSTANT)
128 : : {
129 : 0 : gfc_error ("KIND parameter of %s at %L must be an initialization "
130 : : "expression", name, &k->where);
131 : 0 : return -1;
132 : : }
133 : :
134 : 29762 : if (gfc_extract_int (k, &kind)
135 : 29762 : || gfc_validate_kind (type, kind, true) < 0)
136 : : {
137 : 0 : gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
138 : 0 : return -1;
139 : : }
140 : :
141 : 29762 : return kind;
142 : : }
143 : :
144 : :
145 : : /* Converts an mpz_t signed variable into an unsigned one, assuming
146 : : two's complement representations and a binary width of bitsize.
147 : : The conversion is a no-op unless x is negative; otherwise, it can
148 : : be accomplished by masking out the high bits. */
149 : :
150 : : static void
151 : 3118 : convert_mpz_to_unsigned (mpz_t x, int bitsize)
152 : : {
153 : 3118 : mpz_t mask;
154 : :
155 : 3118 : if (mpz_sgn (x) < 0)
156 : : {
157 : : /* Confirm that no bits above the signed range are unset if we
158 : : are doing range checking. */
159 : 720 : if (flag_range_check != 0)
160 : 720 : gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
161 : :
162 : 720 : mpz_init_set_ui (mask, 1);
163 : 720 : mpz_mul_2exp (mask, mask, bitsize);
164 : 720 : mpz_sub_ui (mask, mask, 1);
165 : :
166 : 720 : mpz_and (x, x, mask);
167 : :
168 : 720 : mpz_clear (mask);
169 : : }
170 : : else
171 : : {
172 : : /* Confirm that no bits above the signed range are set if we
173 : : are doing range checking. */
174 : 2398 : if (flag_range_check != 0)
175 : 2338 : gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
176 : : }
177 : 3118 : }
178 : :
179 : :
180 : : /* Converts an mpz_t unsigned variable into a signed one, assuming
181 : : two's complement representations and a binary width of bitsize.
182 : : If the bitsize-1 bit is set, this is taken as a sign bit and
183 : : the number is converted to the corresponding negative number. */
184 : :
185 : : void
186 : 8916 : gfc_convert_mpz_to_signed (mpz_t x, int bitsize)
187 : : {
188 : 8916 : mpz_t mask;
189 : :
190 : : /* Confirm that no bits above the unsigned range are set if we are
191 : : doing range checking. */
192 : 8916 : if (flag_range_check != 0)
193 : 8774 : gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
194 : :
195 : 8916 : if (mpz_tstbit (x, bitsize - 1) == 1)
196 : : {
197 : 1787 : mpz_init_set_ui (mask, 1);
198 : 1787 : mpz_mul_2exp (mask, mask, bitsize);
199 : 1787 : mpz_sub_ui (mask, mask, 1);
200 : :
201 : : /* We negate the number by hand, zeroing the high bits, that is
202 : : make it the corresponding positive number, and then have it
203 : : negated by GMP, giving the correct representation of the
204 : : negative number. */
205 : 1787 : mpz_com (x, x);
206 : 1787 : mpz_add_ui (x, x, 1);
207 : 1787 : mpz_and (x, x, mask);
208 : :
209 : 1787 : mpz_neg (x, x);
210 : :
211 : 1787 : mpz_clear (mask);
212 : : }
213 : 8916 : }
214 : :
215 : :
216 : : /* Test that the expression is a constant array, simplifying if
217 : : we are dealing with a parameter array. */
218 : :
219 : : static bool
220 : 94581 : is_constant_array_expr (gfc_expr *e)
221 : : {
222 : 94581 : gfc_constructor *c;
223 : 94581 : bool array_OK = true;
224 : 94581 : mpz_t size;
225 : :
226 : 94581 : if (e == NULL)
227 : : return true;
228 : :
229 : 86572 : if (e->expr_type == EXPR_VARIABLE && e->rank > 0
230 : 31087 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
231 : 988 : gfc_simplify_expr (e, 1);
232 : :
233 : 86572 : if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
234 : 67810 : return false;
235 : :
236 : : /* A non-zero-sized constant array shall have a non-empty constructor. */
237 : 18762 : if (e->rank > 0 && e->shape != NULL && e->value.constructor == NULL)
238 : : {
239 : 715 : mpz_init_set_ui (size, 1);
240 : 1640 : for (int j = 0; j < e->rank; j++)
241 : 925 : mpz_mul (size, size, e->shape[j]);
242 : 715 : bool not_size0 = (mpz_cmp_si (size, 0) != 0);
243 : 715 : mpz_clear (size);
244 : 715 : if (not_size0)
245 : : return false;
246 : : }
247 : :
248 : 18759 : for (c = gfc_constructor_first (e->value.constructor);
249 : 365045 : c; c = gfc_constructor_next (c))
250 : 346309 : if (c->expr->expr_type != EXPR_CONSTANT
251 : 505 : && c->expr->expr_type != EXPR_STRUCTURE)
252 : : {
253 : : array_OK = false;
254 : : break;
255 : : }
256 : :
257 : : /* Check and expand the constructor. We do this when either
258 : : gfc_init_expr_flag is set or for not too large array constructors. */
259 : 18759 : bool expand;
260 : 37518 : expand = (e->rank == 1
261 : 18033 : && e->shape
262 : 36785 : && (mpz_cmp_ui (e->shape[0], flag_max_array_constructor) < 0));
263 : :
264 : 18759 : if (!array_OK && (gfc_init_expr_flag || expand) && e->rank == 1)
265 : : {
266 : 17 : bool saved_init_expr_flag = gfc_init_expr_flag;
267 : 17 : array_OK = gfc_reduce_init_expr (e);
268 : : /* gfc_reduce_init_expr resets the flag. */
269 : 17 : gfc_init_expr_flag = saved_init_expr_flag;
270 : : }
271 : : else
272 : : return array_OK;
273 : :
274 : : /* Recheck to make sure that any EXPR_ARRAYs have gone. */
275 : 17 : for (c = gfc_constructor_first (e->value.constructor);
276 : 46 : c; c = gfc_constructor_next (c))
277 : 33 : if (c->expr->expr_type != EXPR_CONSTANT
278 : 4 : && c->expr->expr_type != EXPR_STRUCTURE)
279 : : return false;
280 : :
281 : : /* Make sure that the array has a valid shape. */
282 : 13 : if (e->shape == NULL && e->rank == 1)
283 : : {
284 : 0 : if (!gfc_array_size(e, &size))
285 : : return false;
286 : 0 : e->shape = gfc_get_shape (1);
287 : 0 : mpz_init_set (e->shape[0], size);
288 : 0 : mpz_clear (size);
289 : : }
290 : :
291 : : return array_OK;
292 : : }
293 : :
294 : : bool
295 : 6790 : gfc_is_constant_array_expr (gfc_expr *e)
296 : : {
297 : 6790 : return is_constant_array_expr (e);
298 : : }
299 : :
300 : :
301 : : /* Test for a size zero array. */
302 : : bool
303 : 137168 : gfc_is_size_zero_array (gfc_expr *array)
304 : : {
305 : :
306 : 137168 : if (array->rank == 0)
307 : : return false;
308 : :
309 : 133511 : if (array->expr_type == EXPR_VARIABLE && array->rank > 0
310 : 17483 : && array->symtree->n.sym->attr.flavor == FL_PARAMETER
311 : 6899 : && array->shape != NULL)
312 : : {
313 : 14090 : for (int i = 0; i < array->rank; i++)
314 : 8304 : if (mpz_cmp_si (array->shape[i], 0) <= 0)
315 : : return true;
316 : :
317 : : return false;
318 : : }
319 : :
320 : 126866 : if (array->expr_type == EXPR_ARRAY)
321 : 80470 : return array->value.constructor == NULL;
322 : :
323 : : return false;
324 : : }
325 : :
326 : :
327 : : /* Initialize a transformational result expression with a given value. */
328 : :
329 : : static void
330 : 3248 : init_result_expr (gfc_expr *e, int init, gfc_expr *array)
331 : : {
332 : 3248 : if (e && e->expr_type == EXPR_ARRAY)
333 : : {
334 : 129 : gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
335 : 611 : while (ctor)
336 : : {
337 : 353 : init_result_expr (ctor->expr, init, array);
338 : 353 : ctor = gfc_constructor_next (ctor);
339 : : }
340 : : }
341 : 3119 : else if (e && e->expr_type == EXPR_CONSTANT)
342 : : {
343 : 3119 : int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
344 : 3119 : HOST_WIDE_INT length;
345 : 3119 : gfc_char_t *string;
346 : :
347 : 3119 : switch (e->ts.type)
348 : : {
349 : 1958 : case BT_LOGICAL:
350 : 1958 : e->value.logical = (init ? 1 : 0);
351 : 1958 : break;
352 : :
353 : 789 : case BT_INTEGER:
354 : 789 : if (init == INT_MIN)
355 : 120 : mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
356 : 669 : else if (init == INT_MAX)
357 : 134 : mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
358 : : else
359 : 535 : mpz_set_si (e->value.integer, init);
360 : : break;
361 : :
362 : 280 : case BT_REAL:
363 : 280 : if (init == INT_MIN)
364 : : {
365 : 26 : mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
366 : 26 : mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
367 : : }
368 : 254 : else if (init == INT_MAX)
369 : 27 : mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
370 : : else
371 : 227 : mpfr_set_si (e->value.real, init, GFC_RND_MODE);
372 : : break;
373 : :
374 : 48 : case BT_COMPLEX:
375 : 48 : mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
376 : 48 : break;
377 : :
378 : 44 : case BT_CHARACTER:
379 : 44 : if (init == INT_MIN)
380 : : {
381 : 22 : gfc_expr *len = gfc_simplify_len (array, NULL);
382 : 22 : gfc_extract_hwi (len, &length);
383 : 22 : string = gfc_get_wide_string (length + 1);
384 : 22 : gfc_wide_memset (string, 0, length);
385 : : }
386 : 22 : else if (init == INT_MAX)
387 : : {
388 : 22 : gfc_expr *len = gfc_simplify_len (array, NULL);
389 : 22 : gfc_extract_hwi (len, &length);
390 : 22 : string = gfc_get_wide_string (length + 1);
391 : 22 : gfc_wide_memset (string, 255, length);
392 : : }
393 : : else
394 : : {
395 : 0 : length = 0;
396 : 0 : string = gfc_get_wide_string (1);
397 : : }
398 : :
399 : 44 : string[length] = '\0';
400 : 44 : e->value.character.length = length;
401 : 44 : e->value.character.string = string;
402 : 44 : break;
403 : :
404 : 0 : default:
405 : 0 : gcc_unreachable();
406 : : }
407 : 3119 : }
408 : : else
409 : 0 : gcc_unreachable();
410 : 3248 : }
411 : :
412 : :
413 : : /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
414 : : if conj_a is true, the matrix_a is complex conjugated. */
415 : :
416 : : static gfc_expr *
417 : 338 : compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
418 : : gfc_expr *matrix_b, int stride_b, int offset_b,
419 : : bool conj_a)
420 : : {
421 : 338 : gfc_expr *result, *a, *b, *c;
422 : :
423 : : /* Set result to an INTEGER(1) 0 for numeric types and .false. for
424 : : LOGICAL. Mixed-mode math in the loop will promote result to the
425 : : correct type and kind. */
426 : 338 : if (matrix_a->ts.type == BT_LOGICAL)
427 : 0 : result = gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
428 : : else
429 : 338 : result = gfc_get_int_expr (1, NULL, 0);
430 : 338 : result->where = matrix_a->where;
431 : :
432 : 338 : a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
433 : 338 : b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
434 : 1426 : while (a && b)
435 : : {
436 : : /* Copying of expressions is required as operands are free'd
437 : : by the gfc_arith routines. */
438 : 750 : switch (result->ts.type)
439 : : {
440 : 0 : case BT_LOGICAL:
441 : 0 : result = gfc_or (result,
442 : : gfc_and (gfc_copy_expr (a),
443 : : gfc_copy_expr (b)));
444 : 0 : break;
445 : :
446 : 750 : case BT_INTEGER:
447 : 750 : case BT_REAL:
448 : 750 : case BT_COMPLEX:
449 : 750 : if (conj_a && a->ts.type == BT_COMPLEX)
450 : 2 : c = gfc_simplify_conjg (a);
451 : : else
452 : 748 : c = gfc_copy_expr (a);
453 : 750 : result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b)));
454 : 750 : break;
455 : :
456 : 0 : default:
457 : 0 : gcc_unreachable();
458 : : }
459 : :
460 : 750 : offset_a += stride_a;
461 : 750 : a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
462 : :
463 : 750 : offset_b += stride_b;
464 : 750 : b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
465 : : }
466 : :
467 : 338 : return result;
468 : : }
469 : :
470 : :
471 : : /* Build a result expression for transformational intrinsics,
472 : : depending on DIM. */
473 : :
474 : : static gfc_expr *
475 : 2744 : transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
476 : : int kind, locus* where)
477 : : {
478 : 2744 : gfc_expr *result;
479 : 2744 : int i, nelem;
480 : :
481 : 2744 : if (!dim || array->rank == 1)
482 : 2615 : return gfc_get_constant_expr (type, kind, where);
483 : :
484 : 129 : result = gfc_get_array_expr (type, kind, where);
485 : 129 : result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
486 : 129 : result->rank = array->rank - 1;
487 : :
488 : : /* gfc_array_size() would count the number of elements in the constructor,
489 : : we have not built those yet. */
490 : 129 : nelem = 1;
491 : 258 : for (i = 0; i < result->rank; ++i)
492 : 134 : nelem *= mpz_get_ui (result->shape[i]);
493 : :
494 : 482 : for (i = 0; i < nelem; ++i)
495 : : {
496 : 353 : gfc_constructor_append_expr (&result->value.constructor,
497 : : gfc_get_constant_expr (type, kind, where),
498 : : NULL);
499 : : }
500 : :
501 : : return result;
502 : : }
503 : :
504 : :
505 : : typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
506 : :
507 : : /* Wrapper function, implements 'op1 += 1'. Only called if MASK
508 : : of COUNT intrinsic is .TRUE..
509 : :
510 : : Interface and implementation mimics arith functions as
511 : : gfc_add, gfc_multiply, etc. */
512 : :
513 : : static gfc_expr *
514 : 108 : gfc_count (gfc_expr *op1, gfc_expr *op2)
515 : : {
516 : 108 : gfc_expr *result;
517 : :
518 : 108 : gcc_assert (op1->ts.type == BT_INTEGER);
519 : 108 : gcc_assert (op2->ts.type == BT_LOGICAL);
520 : 108 : gcc_assert (op2->value.logical);
521 : :
522 : 108 : result = gfc_copy_expr (op1);
523 : 108 : mpz_add_ui (result->value.integer, result->value.integer, 1);
524 : :
525 : 108 : gfc_free_expr (op1);
526 : 108 : gfc_free_expr (op2);
527 : 108 : return result;
528 : : }
529 : :
530 : :
531 : : /* Transforms an ARRAY with operation OP, according to MASK, to a
532 : : scalar RESULT. E.g. called if
533 : :
534 : : REAL, PARAMETER :: array(n, m) = ...
535 : : REAL, PARAMETER :: s = SUM(array)
536 : :
537 : : where OP == gfc_add(). */
538 : :
539 : : static gfc_expr *
540 : 2277 : simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
541 : : transformational_op op)
542 : : {
543 : 2277 : gfc_expr *a, *m;
544 : 2277 : gfc_constructor *array_ctor, *mask_ctor;
545 : :
546 : : /* Shortcut for constant .FALSE. MASK. */
547 : 2277 : if (mask
548 : 98 : && mask->expr_type == EXPR_CONSTANT
549 : 24 : && !mask->value.logical)
550 : : return result;
551 : :
552 : 2253 : array_ctor = gfc_constructor_first (array->value.constructor);
553 : 2253 : mask_ctor = NULL;
554 : 2253 : if (mask && mask->expr_type == EXPR_ARRAY)
555 : 74 : mask_ctor = gfc_constructor_first (mask->value.constructor);
556 : :
557 : 69887 : while (array_ctor)
558 : : {
559 : 67634 : a = array_ctor->expr;
560 : 67634 : array_ctor = gfc_constructor_next (array_ctor);
561 : :
562 : : /* A constant MASK equals .TRUE. here and can be ignored. */
563 : 67634 : if (mask_ctor)
564 : : {
565 : 430 : m = mask_ctor->expr;
566 : 430 : mask_ctor = gfc_constructor_next (mask_ctor);
567 : 430 : if (!m->value.logical)
568 : 304 : continue;
569 : : }
570 : :
571 : 67330 : result = op (result, gfc_copy_expr (a));
572 : 67330 : if (!result)
573 : : return result;
574 : : }
575 : :
576 : : return result;
577 : : }
578 : :
579 : : /* Transforms an ARRAY with operation OP, according to MASK, to an
580 : : array RESULT. E.g. called if
581 : :
582 : : REAL, PARAMETER :: array(n, m) = ...
583 : : REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
584 : :
585 : : where OP == gfc_multiply().
586 : : The result might be post processed using post_op. */
587 : :
588 : : static gfc_expr *
589 : 90 : simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
590 : : gfc_expr *mask, transformational_op op,
591 : : transformational_op post_op)
592 : : {
593 : 90 : mpz_t size;
594 : 90 : int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
595 : 90 : gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
596 : 90 : gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
597 : :
598 : 90 : int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
599 : : sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
600 : : tmpstride[GFC_MAX_DIMENSIONS];
601 : :
602 : : /* Shortcut for constant .FALSE. MASK. */
603 : 90 : if (mask
604 : 16 : && mask->expr_type == EXPR_CONSTANT
605 : 0 : && !mask->value.logical)
606 : : return result;
607 : :
608 : : /* Build an indexed table for array element expressions to minimize
609 : : linked-list traversal. Masked elements are set to NULL. */
610 : 90 : gfc_array_size (array, &size);
611 : 90 : arraysize = mpz_get_ui (size);
612 : 90 : mpz_clear (size);
613 : :
614 : 90 : arrayvec = XCNEWVEC (gfc_expr*, arraysize);
615 : :
616 : 90 : array_ctor = gfc_constructor_first (array->value.constructor);
617 : 90 : mask_ctor = NULL;
618 : 90 : if (mask && mask->expr_type == EXPR_ARRAY)
619 : 16 : mask_ctor = gfc_constructor_first (mask->value.constructor);
620 : :
621 : 754 : for (i = 0; i < arraysize; ++i)
622 : : {
623 : 664 : arrayvec[i] = array_ctor->expr;
624 : 664 : array_ctor = gfc_constructor_next (array_ctor);
625 : :
626 : 664 : if (mask_ctor)
627 : : {
628 : 156 : if (!mask_ctor->expr->value.logical)
629 : 83 : arrayvec[i] = NULL;
630 : :
631 : 156 : mask_ctor = gfc_constructor_next (mask_ctor);
632 : : }
633 : : }
634 : :
635 : : /* Same for the result expression. */
636 : 90 : gfc_array_size (result, &size);
637 : 90 : resultsize = mpz_get_ui (size);
638 : 90 : mpz_clear (size);
639 : :
640 : 90 : resultvec = XCNEWVEC (gfc_expr*, resultsize);
641 : 90 : result_ctor = gfc_constructor_first (result->value.constructor);
642 : 432 : for (i = 0; i < resultsize; ++i)
643 : : {
644 : 252 : resultvec[i] = result_ctor->expr;
645 : 252 : result_ctor = gfc_constructor_next (result_ctor);
646 : : }
647 : :
648 : 90 : gfc_extract_int (dim, &dim_index);
649 : 90 : dim_index -= 1; /* zero-base index */
650 : 90 : dim_extent = 0;
651 : 90 : dim_stride = 0;
652 : :
653 : 270 : for (i = 0, n = 0; i < array->rank; ++i)
654 : : {
655 : 180 : count[i] = 0;
656 : 180 : tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
657 : 180 : if (i == dim_index)
658 : : {
659 : 90 : dim_extent = mpz_get_si (array->shape[i]);
660 : 90 : dim_stride = tmpstride[i];
661 : 90 : continue;
662 : : }
663 : :
664 : 90 : extent[n] = mpz_get_si (array->shape[i]);
665 : 90 : sstride[n] = tmpstride[i];
666 : 90 : dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
667 : 90 : n += 1;
668 : : }
669 : :
670 : 90 : done = resultsize <= 0;
671 : 90 : base = arrayvec;
672 : 90 : dest = resultvec;
673 : 342 : while (!done)
674 : : {
675 : 916 : for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
676 : 664 : if (*src)
677 : 581 : *dest = op (*dest, gfc_copy_expr (*src));
678 : :
679 : 252 : if (post_op)
680 : 2 : *dest = post_op (*dest, *dest);
681 : :
682 : 252 : count[0]++;
683 : 252 : base += sstride[0];
684 : 252 : dest += dstride[0];
685 : :
686 : 252 : n = 0;
687 : 342 : while (!done && count[n] == extent[n])
688 : : {
689 : 90 : count[n] = 0;
690 : 90 : base -= sstride[n] * extent[n];
691 : 90 : dest -= dstride[n] * extent[n];
692 : :
693 : 90 : n++;
694 : 90 : if (n < result->rank)
695 : : {
696 : : /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
697 : : times, we'd warn for the last iteration, because the
698 : : array index will have already been incremented to the
699 : : array sizes, and we can't tell that this must make
700 : : the test against result->rank false, because ranks
701 : : must not exceed GFC_MAX_DIMENSIONS. */
702 : 0 : GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
703 : 0 : count[n]++;
704 : 0 : base += sstride[n];
705 : 0 : dest += dstride[n];
706 : 0 : GCC_DIAGNOSTIC_POP
707 : : }
708 : : else
709 : : done = true;
710 : : }
711 : : }
712 : :
713 : : /* Place updated expression in result constructor. */
714 : 90 : result_ctor = gfc_constructor_first (result->value.constructor);
715 : 432 : for (i = 0; i < resultsize; ++i)
716 : : {
717 : 252 : result_ctor->expr = resultvec[i];
718 : 252 : result_ctor = gfc_constructor_next (result_ctor);
719 : : }
720 : :
721 : 90 : free (arrayvec);
722 : 90 : free (resultvec);
723 : 90 : return result;
724 : : }
725 : :
726 : :
727 : : static gfc_expr *
728 : 48715 : simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
729 : : int init_val, transformational_op op)
730 : : {
731 : 48715 : gfc_expr *result;
732 : 48715 : bool size_zero;
733 : :
734 : 48715 : size_zero = gfc_is_size_zero_array (array);
735 : :
736 : 94735 : if (!(is_constant_array_expr (array) || size_zero)
737 : 2695 : || array->shape == NULL
738 : 51407 : || !gfc_is_constant_expr (dim))
739 : 46023 : return NULL;
740 : :
741 : 2692 : if (mask
742 : 242 : && !is_constant_array_expr (mask)
743 : 2874 : && mask->expr_type != EXPR_CONSTANT)
744 : : return NULL;
745 : :
746 : 2534 : result = transformational_result (array, dim, array->ts.type,
747 : : array->ts.kind, &array->where);
748 : 2534 : init_result_expr (result, init_val, array);
749 : :
750 : 2534 : if (size_zero)
751 : : return result;
752 : :
753 : 2299 : return !dim || array->rank == 1 ?
754 : 2216 : simplify_transformation_to_scalar (result, array, mask, op) :
755 : 83 : simplify_transformation_to_array (result, array, dim, mask, op, NULL);
756 : : }
757 : :
758 : :
759 : : /********************** Simplification functions *****************************/
760 : :
761 : : gfc_expr *
762 : 24596 : gfc_simplify_abs (gfc_expr *e)
763 : : {
764 : 24596 : gfc_expr *result;
765 : :
766 : 24596 : if (e->expr_type != EXPR_CONSTANT)
767 : : return NULL;
768 : :
769 : 980 : switch (e->ts.type)
770 : : {
771 : 36 : case BT_INTEGER:
772 : 36 : result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
773 : 36 : mpz_abs (result->value.integer, e->value.integer);
774 : 36 : return range_check (result, "IABS");
775 : :
776 : 782 : case BT_REAL:
777 : 782 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
778 : 782 : mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
779 : 782 : return range_check (result, "ABS");
780 : :
781 : 162 : case BT_COMPLEX:
782 : 162 : gfc_set_model_kind (e->ts.kind);
783 : 162 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
784 : 162 : mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
785 : 162 : return range_check (result, "CABS");
786 : :
787 : 0 : default:
788 : 0 : gfc_internal_error ("gfc_simplify_abs(): Bad type");
789 : : }
790 : : }
791 : :
792 : :
793 : : static gfc_expr *
794 : 20575 : simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
795 : : {
796 : 20575 : gfc_expr *result;
797 : 20575 : int kind;
798 : 20575 : bool too_large = false;
799 : :
800 : 20575 : if (e->expr_type != EXPR_CONSTANT)
801 : : return NULL;
802 : :
803 : 13397 : kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
804 : 13397 : if (kind == -1)
805 : : return &gfc_bad_expr;
806 : :
807 : 13397 : if (mpz_cmp_si (e->value.integer, 0) < 0)
808 : : {
809 : 8 : gfc_error ("Argument of %s function at %L is negative", name,
810 : : &e->where);
811 : 8 : return &gfc_bad_expr;
812 : : }
813 : :
814 : 13389 : if (ascii && warn_surprising && mpz_cmp_si (e->value.integer, 127) > 0)
815 : 1 : gfc_warning (OPT_Wsurprising,
816 : : "Argument of %s function at %L outside of range [0,127]",
817 : : name, &e->where);
818 : :
819 : 13389 : if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
820 : : too_large = true;
821 : 13380 : else if (kind == 4)
822 : : {
823 : 1408 : mpz_t t;
824 : 1408 : mpz_init_set_ui (t, 2);
825 : 1408 : mpz_pow_ui (t, t, 32);
826 : 1408 : mpz_sub_ui (t, t, 1);
827 : 1408 : if (mpz_cmp (e->value.integer, t) > 0)
828 : 2 : too_large = true;
829 : 1408 : mpz_clear (t);
830 : : }
831 : :
832 : 1408 : if (too_large)
833 : : {
834 : 11 : gfc_error ("Argument of %s function at %L is too large for the "
835 : : "collating sequence of kind %d", name, &e->where, kind);
836 : 11 : return &gfc_bad_expr;
837 : : }
838 : :
839 : 13378 : result = gfc_get_character_expr (kind, &e->where, NULL, 1);
840 : 13378 : result->value.character.string[0] = mpz_get_ui (e->value.integer);
841 : :
842 : 13378 : return result;
843 : : }
844 : :
845 : :
846 : :
847 : : /* We use the processor's collating sequence, because all
848 : : systems that gfortran currently works on are ASCII. */
849 : :
850 : : gfc_expr *
851 : 13058 : gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
852 : : {
853 : 13058 : return simplify_achar_char (e, k, "ACHAR", true);
854 : : }
855 : :
856 : :
857 : : gfc_expr *
858 : 546 : gfc_simplify_acos (gfc_expr *x)
859 : : {
860 : 546 : gfc_expr *result;
861 : :
862 : 546 : if (x->expr_type != EXPR_CONSTANT)
863 : : return NULL;
864 : :
865 : 82 : switch (x->ts.type)
866 : : {
867 : 78 : case BT_REAL:
868 : 78 : if (mpfr_cmp_si (x->value.real, 1) > 0
869 : 78 : || mpfr_cmp_si (x->value.real, -1) < 0)
870 : : {
871 : 0 : gfc_error ("Argument of ACOS at %L must be between -1 and 1",
872 : : &x->where);
873 : 0 : return &gfc_bad_expr;
874 : : }
875 : 78 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
876 : 78 : mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
877 : 78 : break;
878 : :
879 : 4 : case BT_COMPLEX:
880 : 4 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
881 : 4 : mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
882 : 4 : break;
883 : :
884 : 0 : default:
885 : 0 : gfc_internal_error ("in gfc_simplify_acos(): Bad type");
886 : : }
887 : :
888 : 82 : return range_check (result, "ACOS");
889 : : }
890 : :
891 : : gfc_expr *
892 : 266 : gfc_simplify_acosh (gfc_expr *x)
893 : : {
894 : 266 : gfc_expr *result;
895 : :
896 : 266 : if (x->expr_type != EXPR_CONSTANT)
897 : : return NULL;
898 : :
899 : 34 : switch (x->ts.type)
900 : : {
901 : 30 : case BT_REAL:
902 : 30 : if (mpfr_cmp_si (x->value.real, 1) < 0)
903 : : {
904 : 0 : gfc_error ("Argument of ACOSH at %L must not be less than 1",
905 : : &x->where);
906 : 0 : return &gfc_bad_expr;
907 : : }
908 : :
909 : 30 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
910 : 30 : mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
911 : 30 : 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_acosh (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_acosh(): Bad type");
920 : : }
921 : :
922 : 34 : return range_check (result, "ACOSH");
923 : : }
924 : :
925 : : gfc_expr *
926 : 1164 : gfc_simplify_adjustl (gfc_expr *e)
927 : : {
928 : 1164 : gfc_expr *result;
929 : 1164 : int count, i, len;
930 : 1164 : gfc_char_t ch;
931 : :
932 : 1164 : if (e->expr_type != EXPR_CONSTANT)
933 : : return NULL;
934 : :
935 : 31 : len = e->value.character.length;
936 : :
937 : 89 : for (count = 0, i = 0; i < len; ++i)
938 : : {
939 : 89 : ch = e->value.character.string[i];
940 : 89 : if (ch != ' ')
941 : : break;
942 : 58 : ++count;
943 : : }
944 : :
945 : 31 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
946 : 476 : for (i = 0; i < len - count; ++i)
947 : 414 : result->value.character.string[i] = e->value.character.string[count + i];
948 : :
949 : : return result;
950 : : }
951 : :
952 : :
953 : : gfc_expr *
954 : 347 : gfc_simplify_adjustr (gfc_expr *e)
955 : : {
956 : 347 : gfc_expr *result;
957 : 347 : int count, i, len;
958 : 347 : gfc_char_t ch;
959 : :
960 : 347 : if (e->expr_type != EXPR_CONSTANT)
961 : : return NULL;
962 : :
963 : 23 : len = e->value.character.length;
964 : :
965 : 173 : for (count = 0, i = len - 1; i >= 0; --i)
966 : : {
967 : 173 : ch = e->value.character.string[i];
968 : 173 : if (ch != ' ')
969 : : break;
970 : 150 : ++count;
971 : : }
972 : :
973 : 23 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
974 : 196 : for (i = 0; i < count; ++i)
975 : 150 : result->value.character.string[i] = ' ';
976 : :
977 : 260 : for (i = count; i < len; ++i)
978 : 237 : result->value.character.string[i] = e->value.character.string[i - count];
979 : :
980 : : return result;
981 : : }
982 : :
983 : :
984 : : gfc_expr *
985 : 1714 : gfc_simplify_aimag (gfc_expr *e)
986 : : {
987 : 1714 : gfc_expr *result;
988 : :
989 : 1714 : if (e->expr_type != EXPR_CONSTANT)
990 : : return NULL;
991 : :
992 : 144 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
993 : 144 : mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
994 : :
995 : 144 : return range_check (result, "AIMAG");
996 : : }
997 : :
998 : :
999 : : gfc_expr *
1000 : 594 : gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
1001 : : {
1002 : 594 : gfc_expr *rtrunc, *result;
1003 : 594 : int kind;
1004 : :
1005 : 594 : kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
1006 : 594 : if (kind == -1)
1007 : : return &gfc_bad_expr;
1008 : :
1009 : 594 : if (e->expr_type != EXPR_CONSTANT)
1010 : : return NULL;
1011 : :
1012 : 31 : rtrunc = gfc_copy_expr (e);
1013 : 31 : mpfr_trunc (rtrunc->value.real, e->value.real);
1014 : :
1015 : 31 : result = gfc_real2real (rtrunc, kind);
1016 : :
1017 : 31 : gfc_free_expr (rtrunc);
1018 : :
1019 : 31 : return range_check (result, "AINT");
1020 : : }
1021 : :
1022 : :
1023 : : gfc_expr *
1024 : 1319 : gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
1025 : : {
1026 : 1319 : return simplify_transformation (mask, dim, NULL, true, gfc_and);
1027 : : }
1028 : :
1029 : :
1030 : : gfc_expr *
1031 : 63 : gfc_simplify_dint (gfc_expr *e)
1032 : : {
1033 : 63 : gfc_expr *rtrunc, *result;
1034 : :
1035 : 63 : if (e->expr_type != EXPR_CONSTANT)
1036 : : return NULL;
1037 : :
1038 : 16 : rtrunc = gfc_copy_expr (e);
1039 : 16 : mpfr_trunc (rtrunc->value.real, e->value.real);
1040 : :
1041 : 16 : result = gfc_real2real (rtrunc, gfc_default_double_kind);
1042 : :
1043 : 16 : gfc_free_expr (rtrunc);
1044 : :
1045 : 16 : return range_check (result, "DINT");
1046 : : }
1047 : :
1048 : :
1049 : : gfc_expr *
1050 : 3 : gfc_simplify_dreal (gfc_expr *e)
1051 : : {
1052 : 3 : gfc_expr *result = NULL;
1053 : :
1054 : 3 : if (e->expr_type != EXPR_CONSTANT)
1055 : : return NULL;
1056 : :
1057 : 1 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
1058 : 1 : mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
1059 : :
1060 : 1 : return range_check (result, "DREAL");
1061 : : }
1062 : :
1063 : :
1064 : : gfc_expr *
1065 : 162 : gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
1066 : : {
1067 : 162 : gfc_expr *result;
1068 : 162 : int kind;
1069 : :
1070 : 162 : kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
1071 : 162 : if (kind == -1)
1072 : : return &gfc_bad_expr;
1073 : :
1074 : 162 : if (e->expr_type != EXPR_CONSTANT)
1075 : : return NULL;
1076 : :
1077 : 55 : result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
1078 : 55 : mpfr_round (result->value.real, e->value.real);
1079 : :
1080 : 55 : return range_check (result, "ANINT");
1081 : : }
1082 : :
1083 : :
1084 : : gfc_expr *
1085 : 334 : gfc_simplify_and (gfc_expr *x, gfc_expr *y)
1086 : : {
1087 : 334 : gfc_expr *result;
1088 : 334 : int kind;
1089 : :
1090 : 334 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1091 : : return NULL;
1092 : :
1093 : 7 : kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
1094 : :
1095 : 7 : switch (x->ts.type)
1096 : : {
1097 : 1 : case BT_INTEGER:
1098 : 1 : result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
1099 : 1 : mpz_and (result->value.integer, x->value.integer, y->value.integer);
1100 : 1 : return range_check (result, "AND");
1101 : :
1102 : 6 : case BT_LOGICAL:
1103 : 6 : return gfc_get_logical_expr (kind, &x->where,
1104 : 12 : x->value.logical && y->value.logical);
1105 : :
1106 : 0 : default:
1107 : 0 : gcc_unreachable ();
1108 : : }
1109 : : }
1110 : :
1111 : :
1112 : : gfc_expr *
1113 : 34792 : gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
1114 : : {
1115 : 34792 : return simplify_transformation (mask, dim, NULL, false, gfc_or);
1116 : : }
1117 : :
1118 : :
1119 : : gfc_expr *
1120 : 105 : gfc_simplify_dnint (gfc_expr *e)
1121 : : {
1122 : 105 : gfc_expr *result;
1123 : :
1124 : 105 : if (e->expr_type != EXPR_CONSTANT)
1125 : : return NULL;
1126 : :
1127 : 46 : result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
1128 : 46 : mpfr_round (result->value.real, e->value.real);
1129 : :
1130 : 46 : return range_check (result, "DNINT");
1131 : : }
1132 : :
1133 : :
1134 : : gfc_expr *
1135 : 556 : gfc_simplify_asin (gfc_expr *x)
1136 : : {
1137 : 556 : gfc_expr *result;
1138 : :
1139 : 556 : if (x->expr_type != EXPR_CONSTANT)
1140 : : return NULL;
1141 : :
1142 : 59 : switch (x->ts.type)
1143 : : {
1144 : 55 : case BT_REAL:
1145 : 55 : if (mpfr_cmp_si (x->value.real, 1) > 0
1146 : 55 : || mpfr_cmp_si (x->value.real, -1) < 0)
1147 : : {
1148 : 0 : gfc_error ("Argument of ASIN at %L must be between -1 and 1",
1149 : : &x->where);
1150 : 0 : return &gfc_bad_expr;
1151 : : }
1152 : 55 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1153 : 55 : mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1154 : 55 : break;
1155 : :
1156 : 4 : case BT_COMPLEX:
1157 : 4 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1158 : 4 : mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1159 : 4 : break;
1160 : :
1161 : 0 : default:
1162 : 0 : gfc_internal_error ("in gfc_simplify_asin(): Bad type");
1163 : : }
1164 : :
1165 : 59 : return range_check (result, "ASIN");
1166 : : }
1167 : :
1168 : :
1169 : : /* Convert radians to degrees, i.e., x * 180 / pi. */
1170 : :
1171 : : static void
1172 : 96 : rad2deg (mpfr_t x)
1173 : : {
1174 : 96 : mpfr_t tmp;
1175 : :
1176 : 96 : mpfr_init (tmp);
1177 : 96 : mpfr_const_pi (tmp, GFC_RND_MODE);
1178 : 96 : mpfr_mul_ui (x, x, 180, GFC_RND_MODE);
1179 : 96 : mpfr_div (x, x, tmp, GFC_RND_MODE);
1180 : 96 : mpfr_clear (tmp);
1181 : 96 : }
1182 : :
1183 : :
1184 : : /* Simplify ACOSD(X) where the returned value has units of degree. */
1185 : :
1186 : : gfc_expr *
1187 : 168 : gfc_simplify_acosd (gfc_expr *x)
1188 : : {
1189 : 168 : gfc_expr *result;
1190 : :
1191 : 168 : if (x->expr_type != EXPR_CONSTANT)
1192 : : return NULL;
1193 : :
1194 : 24 : if (mpfr_cmp_si (x->value.real, 1) > 0
1195 : 24 : || mpfr_cmp_si (x->value.real, -1) < 0)
1196 : : {
1197 : 0 : gfc_error ("Argument of ACOSD at %L must be between -1 and 1",
1198 : : &x->where);
1199 : 0 : return &gfc_bad_expr;
1200 : : }
1201 : :
1202 : 24 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1203 : 24 : mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
1204 : 24 : rad2deg (result->value.real);
1205 : :
1206 : 24 : return range_check (result, "ACOSD");
1207 : : }
1208 : :
1209 : :
1210 : : /* Simplify asind (x) where the returned value has units of degree. */
1211 : :
1212 : : gfc_expr *
1213 : 169 : gfc_simplify_asind (gfc_expr *x)
1214 : : {
1215 : 169 : gfc_expr *result;
1216 : :
1217 : 169 : if (x->expr_type != EXPR_CONSTANT)
1218 : : return NULL;
1219 : :
1220 : 25 : if (mpfr_cmp_si (x->value.real, 1) > 0
1221 : 25 : || mpfr_cmp_si (x->value.real, -1) < 0)
1222 : : {
1223 : 1 : gfc_error ("Argument of ASIND at %L must be between -1 and 1",
1224 : : &x->where);
1225 : 1 : return &gfc_bad_expr;
1226 : : }
1227 : :
1228 : 24 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1229 : 24 : mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
1230 : 24 : rad2deg (result->value.real);
1231 : :
1232 : 24 : return range_check (result, "ASIND");
1233 : : }
1234 : :
1235 : :
1236 : : /* Simplify atand (x) where the returned value has units of degree. */
1237 : :
1238 : : gfc_expr *
1239 : 168 : gfc_simplify_atand (gfc_expr *x)
1240 : : {
1241 : 168 : gfc_expr *result;
1242 : :
1243 : 168 : if (x->expr_type != EXPR_CONSTANT)
1244 : : return NULL;
1245 : :
1246 : 24 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1247 : 24 : mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1248 : 24 : rad2deg (result->value.real);
1249 : :
1250 : 24 : return range_check (result, "ATAND");
1251 : : }
1252 : :
1253 : :
1254 : : gfc_expr *
1255 : 269 : gfc_simplify_asinh (gfc_expr *x)
1256 : : {
1257 : 269 : gfc_expr *result;
1258 : :
1259 : 269 : if (x->expr_type != EXPR_CONSTANT)
1260 : : return NULL;
1261 : :
1262 : 37 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1263 : :
1264 : 37 : switch (x->ts.type)
1265 : : {
1266 : 33 : case BT_REAL:
1267 : 33 : mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
1268 : 33 : break;
1269 : :
1270 : 4 : case BT_COMPLEX:
1271 : 4 : mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1272 : 4 : break;
1273 : :
1274 : 0 : default:
1275 : 0 : gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
1276 : : }
1277 : :
1278 : 37 : return range_check (result, "ASINH");
1279 : : }
1280 : :
1281 : :
1282 : : gfc_expr *
1283 : 615 : gfc_simplify_atan (gfc_expr *x)
1284 : : {
1285 : 615 : gfc_expr *result;
1286 : :
1287 : 615 : if (x->expr_type != EXPR_CONSTANT)
1288 : : return NULL;
1289 : :
1290 : 103 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1291 : :
1292 : 103 : switch (x->ts.type)
1293 : : {
1294 : 99 : case BT_REAL:
1295 : 99 : mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
1296 : 99 : break;
1297 : :
1298 : 4 : case BT_COMPLEX:
1299 : 4 : mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1300 : 4 : break;
1301 : :
1302 : 0 : default:
1303 : 0 : gfc_internal_error ("in gfc_simplify_atan(): Bad type");
1304 : : }
1305 : :
1306 : 103 : return range_check (result, "ATAN");
1307 : : }
1308 : :
1309 : :
1310 : : gfc_expr *
1311 : 266 : gfc_simplify_atanh (gfc_expr *x)
1312 : : {
1313 : 266 : gfc_expr *result;
1314 : :
1315 : 266 : if (x->expr_type != EXPR_CONSTANT)
1316 : : return NULL;
1317 : :
1318 : 34 : switch (x->ts.type)
1319 : : {
1320 : 30 : case BT_REAL:
1321 : 30 : if (mpfr_cmp_si (x->value.real, 1) >= 0
1322 : 30 : || mpfr_cmp_si (x->value.real, -1) <= 0)
1323 : : {
1324 : 0 : gfc_error ("Argument of ATANH at %L must be inside the range -1 "
1325 : : "to 1", &x->where);
1326 : 0 : return &gfc_bad_expr;
1327 : : }
1328 : 30 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1329 : 30 : mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
1330 : 30 : break;
1331 : :
1332 : 4 : case BT_COMPLEX:
1333 : 4 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1334 : 4 : mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1335 : 4 : break;
1336 : :
1337 : 0 : default:
1338 : 0 : gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
1339 : : }
1340 : :
1341 : 34 : return range_check (result, "ATANH");
1342 : : }
1343 : :
1344 : :
1345 : : gfc_expr *
1346 : 743 : gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
1347 : : {
1348 : 743 : gfc_expr *result;
1349 : :
1350 : 743 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1351 : : return NULL;
1352 : :
1353 : 324 : if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
1354 : : {
1355 : 0 : gfc_error ("If first argument of ATAN2 at %L is zero, then the "
1356 : : "second argument must not be zero", &y->where);
1357 : 0 : return &gfc_bad_expr;
1358 : : }
1359 : :
1360 : 324 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1361 : 324 : mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
1362 : :
1363 : 324 : return range_check (result, "ATAN2");
1364 : : }
1365 : :
1366 : :
1367 : : gfc_expr *
1368 : 82 : gfc_simplify_bessel_j0 (gfc_expr *x)
1369 : : {
1370 : 82 : gfc_expr *result;
1371 : :
1372 : 82 : if (x->expr_type != EXPR_CONSTANT)
1373 : : return NULL;
1374 : :
1375 : 14 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1376 : 14 : mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
1377 : :
1378 : 14 : return range_check (result, "BESSEL_J0");
1379 : : }
1380 : :
1381 : :
1382 : : gfc_expr *
1383 : 80 : gfc_simplify_bessel_j1 (gfc_expr *x)
1384 : : {
1385 : 80 : gfc_expr *result;
1386 : :
1387 : 80 : if (x->expr_type != EXPR_CONSTANT)
1388 : : return NULL;
1389 : :
1390 : 12 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1391 : 12 : mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
1392 : :
1393 : 12 : return range_check (result, "BESSEL_J1");
1394 : : }
1395 : :
1396 : :
1397 : : gfc_expr *
1398 : 1287 : gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
1399 : : {
1400 : 1287 : gfc_expr *result;
1401 : 1287 : long n;
1402 : :
1403 : 1287 : if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1404 : : return NULL;
1405 : :
1406 : 1054 : n = mpz_get_si (order->value.integer);
1407 : 1054 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1408 : 1054 : mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
1409 : :
1410 : 1054 : return range_check (result, "BESSEL_JN");
1411 : : }
1412 : :
1413 : :
1414 : : /* Simplify transformational form of JN and YN. */
1415 : :
1416 : : static gfc_expr *
1417 : 71 : gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
1418 : : bool jn)
1419 : : {
1420 : 71 : gfc_expr *result;
1421 : 71 : gfc_expr *e;
1422 : 71 : long n1, n2;
1423 : 71 : int i;
1424 : 71 : mpfr_t x2rev, last1, last2;
1425 : :
1426 : 71 : if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT
1427 : 57 : || order2->expr_type != EXPR_CONSTANT)
1428 : : return NULL;
1429 : :
1430 : 57 : n1 = mpz_get_si (order1->value.integer);
1431 : 57 : n2 = mpz_get_si (order2->value.integer);
1432 : 57 : result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where);
1433 : 57 : result->rank = 1;
1434 : 57 : result->shape = gfc_get_shape (1);
1435 : 57 : mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0));
1436 : :
1437 : 57 : if (n2 < n1)
1438 : : return result;
1439 : :
1440 : : /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
1441 : : YN(N, 0.0) = -Inf. */
1442 : :
1443 : 57 : if (mpfr_cmp_ui (x->value.real, 0.0) == 0)
1444 : : {
1445 : 14 : if (!jn && flag_range_check)
1446 : : {
1447 : 1 : gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where);
1448 : 1 : gfc_free_expr (result);
1449 : 1 : return &gfc_bad_expr;
1450 : : }
1451 : :
1452 : 13 : if (jn && n1 == 0)
1453 : : {
1454 : 7 : e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1455 : 7 : mpfr_set_ui (e->value.real, 1, GFC_RND_MODE);
1456 : 7 : gfc_constructor_append_expr (&result->value.constructor, e,
1457 : : &x->where);
1458 : 7 : n1++;
1459 : : }
1460 : :
1461 : 149 : for (i = n1; i <= n2; i++)
1462 : : {
1463 : 136 : e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1464 : 136 : if (jn)
1465 : 70 : mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
1466 : : else
1467 : 66 : mpfr_set_inf (e->value.real, -1);
1468 : 136 : gfc_constructor_append_expr (&result->value.constructor, e,
1469 : : &x->where);
1470 : : }
1471 : :
1472 : : return result;
1473 : : }
1474 : :
1475 : : /* Use the faster but more verbose recurrence algorithm. Bessel functions
1476 : : are stable for downward recursion and Neumann functions are stable
1477 : : for upward recursion. It is
1478 : : x2rev = 2.0/x,
1479 : : J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
1480 : : Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
1481 : : Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
1482 : :
1483 : 43 : gfc_set_model_kind (x->ts.kind);
1484 : :
1485 : : /* Get first recursion anchor. */
1486 : :
1487 : 43 : mpfr_init (last1);
1488 : 43 : if (jn)
1489 : 22 : mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE);
1490 : : else
1491 : 21 : mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE);
1492 : :
1493 : 43 : e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1494 : 43 : mpfr_set (e->value.real, last1, GFC_RND_MODE);
1495 : 64 : if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1496 : : {
1497 : 0 : mpfr_clear (last1);
1498 : 0 : gfc_free_expr (e);
1499 : 0 : gfc_free_expr (result);
1500 : 0 : return &gfc_bad_expr;
1501 : : }
1502 : 43 : gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1503 : :
1504 : 43 : if (n1 == n2)
1505 : : {
1506 : 0 : mpfr_clear (last1);
1507 : 0 : return result;
1508 : : }
1509 : :
1510 : : /* Get second recursion anchor. */
1511 : :
1512 : 43 : mpfr_init (last2);
1513 : 43 : if (jn)
1514 : 22 : mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE);
1515 : : else
1516 : 21 : mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE);
1517 : :
1518 : 43 : e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1519 : 43 : mpfr_set (e->value.real, last2, GFC_RND_MODE);
1520 : 43 : if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1521 : : {
1522 : 0 : mpfr_clear (last1);
1523 : 0 : mpfr_clear (last2);
1524 : 0 : gfc_free_expr (e);
1525 : 0 : gfc_free_expr (result);
1526 : 0 : return &gfc_bad_expr;
1527 : : }
1528 : 43 : if (jn)
1529 : 22 : gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
1530 : : else
1531 : 21 : gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1532 : :
1533 : 43 : if (n1 + 1 == n2)
1534 : : {
1535 : 1 : mpfr_clear (last1);
1536 : 1 : mpfr_clear (last2);
1537 : 1 : return result;
1538 : : }
1539 : :
1540 : : /* Start actual recursion. */
1541 : :
1542 : 42 : mpfr_init (x2rev);
1543 : 42 : mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
1544 : :
1545 : 322 : for (i = 2; i <= n2-n1; i++)
1546 : : {
1547 : 280 : e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1548 : :
1549 : : /* Special case: For YN, if the previous N gave -INF, set
1550 : : also N+1 to -INF. */
1551 : 280 : if (!jn && !flag_range_check && mpfr_inf_p (last2))
1552 : : {
1553 : 0 : mpfr_set_inf (e->value.real, -1);
1554 : 0 : gfc_constructor_append_expr (&result->value.constructor, e,
1555 : : &x->where);
1556 : 0 : continue;
1557 : : }
1558 : :
1559 : 280 : mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1),
1560 : : GFC_RND_MODE);
1561 : 280 : mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE);
1562 : 280 : mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE);
1563 : :
1564 : 280 : if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
1565 : : {
1566 : : /* Range_check frees "e" in that case. */
1567 : 0 : e = NULL;
1568 : 0 : goto error;
1569 : : }
1570 : :
1571 : 280 : if (jn)
1572 : 140 : gfc_constructor_insert_expr (&result->value.constructor, e, &x->where,
1573 : : -i-1);
1574 : : else
1575 : 140 : gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
1576 : :
1577 : 280 : mpfr_set (last1, last2, GFC_RND_MODE);
1578 : 280 : mpfr_set (last2, e->value.real, GFC_RND_MODE);
1579 : : }
1580 : :
1581 : 42 : mpfr_clear (last1);
1582 : 42 : mpfr_clear (last2);
1583 : 42 : mpfr_clear (x2rev);
1584 : 42 : return result;
1585 : :
1586 : 0 : error:
1587 : 0 : mpfr_clear (last1);
1588 : 0 : mpfr_clear (last2);
1589 : 0 : mpfr_clear (x2rev);
1590 : 0 : gfc_free_expr (e);
1591 : 0 : gfc_free_expr (result);
1592 : 0 : return &gfc_bad_expr;
1593 : : }
1594 : :
1595 : :
1596 : : gfc_expr *
1597 : 31 : gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1598 : : {
1599 : 31 : return gfc_simplify_bessel_n2 (order1, order2, x, true);
1600 : : }
1601 : :
1602 : :
1603 : : gfc_expr *
1604 : 80 : gfc_simplify_bessel_y0 (gfc_expr *x)
1605 : : {
1606 : 80 : gfc_expr *result;
1607 : :
1608 : 80 : if (x->expr_type != EXPR_CONSTANT)
1609 : : return NULL;
1610 : :
1611 : 12 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1612 : 12 : mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
1613 : :
1614 : 12 : return range_check (result, "BESSEL_Y0");
1615 : : }
1616 : :
1617 : :
1618 : : gfc_expr *
1619 : 80 : gfc_simplify_bessel_y1 (gfc_expr *x)
1620 : : {
1621 : 80 : gfc_expr *result;
1622 : :
1623 : 80 : if (x->expr_type != EXPR_CONSTANT)
1624 : : return NULL;
1625 : :
1626 : 12 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1627 : 12 : mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
1628 : :
1629 : 12 : return range_check (result, "BESSEL_Y1");
1630 : : }
1631 : :
1632 : :
1633 : : gfc_expr *
1634 : 1868 : gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
1635 : : {
1636 : 1868 : gfc_expr *result;
1637 : 1868 : long n;
1638 : :
1639 : 1868 : if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
1640 : : return NULL;
1641 : :
1642 : 1010 : n = mpz_get_si (order->value.integer);
1643 : 1010 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1644 : 1010 : mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
1645 : :
1646 : 1010 : return range_check (result, "BESSEL_YN");
1647 : : }
1648 : :
1649 : :
1650 : : gfc_expr *
1651 : 40 : gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1652 : : {
1653 : 40 : return gfc_simplify_bessel_n2 (order1, order2, x, false);
1654 : : }
1655 : :
1656 : :
1657 : : gfc_expr *
1658 : 3625 : gfc_simplify_bit_size (gfc_expr *e)
1659 : : {
1660 : 3625 : int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1661 : 3625 : return gfc_get_int_expr (e->ts.kind, &e->where,
1662 : 3625 : gfc_integer_kinds[i].bit_size);
1663 : : }
1664 : :
1665 : :
1666 : : gfc_expr *
1667 : 315 : gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
1668 : : {
1669 : 315 : int b;
1670 : :
1671 : 315 : if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
1672 : : return NULL;
1673 : :
1674 : 19 : if (!gfc_check_bitfcn (e, bit))
1675 : : return &gfc_bad_expr;
1676 : :
1677 : 11 : if (gfc_extract_int (bit, &b) || b < 0)
1678 : 0 : return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
1679 : :
1680 : 11 : return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
1681 : 11 : mpz_tstbit (e->value.integer, b));
1682 : : }
1683 : :
1684 : :
1685 : : static int
1686 : 1014 : compare_bitwise (gfc_expr *i, gfc_expr *j)
1687 : : {
1688 : 1014 : mpz_t x, y;
1689 : 1014 : int k, res;
1690 : :
1691 : 1014 : gcc_assert (i->ts.type == BT_INTEGER);
1692 : 1014 : gcc_assert (j->ts.type == BT_INTEGER);
1693 : :
1694 : 1014 : mpz_init_set (x, i->value.integer);
1695 : 1014 : k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
1696 : 1014 : convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
1697 : :
1698 : 1014 : mpz_init_set (y, j->value.integer);
1699 : 1014 : k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
1700 : 1014 : convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
1701 : :
1702 : 1014 : res = mpz_cmp (x, y);
1703 : 1014 : mpz_clear (x);
1704 : 1014 : mpz_clear (y);
1705 : 1014 : return res;
1706 : : }
1707 : :
1708 : :
1709 : : gfc_expr *
1710 : 372 : gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
1711 : : {
1712 : 372 : if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1713 : : return NULL;
1714 : :
1715 : 276 : return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1716 : 552 : compare_bitwise (i, j) >= 0);
1717 : : }
1718 : :
1719 : :
1720 : : gfc_expr *
1721 : 342 : gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
1722 : : {
1723 : 342 : if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1724 : : return NULL;
1725 : :
1726 : 246 : return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1727 : 492 : compare_bitwise (i, j) > 0);
1728 : : }
1729 : :
1730 : :
1731 : : gfc_expr *
1732 : 342 : gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
1733 : : {
1734 : 342 : if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1735 : : return NULL;
1736 : :
1737 : 246 : return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1738 : 492 : compare_bitwise (i, j) <= 0);
1739 : : }
1740 : :
1741 : :
1742 : : gfc_expr *
1743 : 342 : gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
1744 : : {
1745 : 342 : if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
1746 : : return NULL;
1747 : :
1748 : 246 : return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
1749 : 492 : compare_bitwise (i, j) < 0);
1750 : : }
1751 : :
1752 : :
1753 : : gfc_expr *
1754 : 90 : gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
1755 : : {
1756 : 90 : gfc_expr *ceil, *result;
1757 : 90 : int kind;
1758 : :
1759 : 90 : kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
1760 : 90 : if (kind == -1)
1761 : : return &gfc_bad_expr;
1762 : :
1763 : 90 : if (e->expr_type != EXPR_CONSTANT)
1764 : : return NULL;
1765 : :
1766 : 13 : ceil = gfc_copy_expr (e);
1767 : 13 : mpfr_ceil (ceil->value.real, e->value.real);
1768 : :
1769 : 13 : result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
1770 : 13 : gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
1771 : :
1772 : 13 : gfc_free_expr (ceil);
1773 : :
1774 : 13 : return range_check (result, "CEILING");
1775 : : }
1776 : :
1777 : :
1778 : : gfc_expr *
1779 : 7517 : gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1780 : : {
1781 : 7517 : return simplify_achar_char (e, k, "CHAR", false);
1782 : : }
1783 : :
1784 : :
1785 : : /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
1786 : :
1787 : : static gfc_expr *
1788 : 6815 : simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1789 : : {
1790 : 6815 : gfc_expr *result;
1791 : :
1792 : 6815 : if (x->expr_type != EXPR_CONSTANT
1793 : 5283 : || (y != NULL && y->expr_type != EXPR_CONSTANT))
1794 : : return NULL;
1795 : :
1796 : 5173 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
1797 : :
1798 : 5173 : switch (x->ts.type)
1799 : : {
1800 : 3634 : case BT_INTEGER:
1801 : 3634 : mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
1802 : 3634 : break;
1803 : :
1804 : 1539 : case BT_REAL:
1805 : 1539 : mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
1806 : 1539 : break;
1807 : :
1808 : 0 : case BT_COMPLEX:
1809 : 0 : mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1810 : 0 : break;
1811 : :
1812 : 0 : default:
1813 : 0 : gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
1814 : : }
1815 : :
1816 : 5173 : if (!y)
1817 : 224 : return range_check (result, name);
1818 : :
1819 : 4949 : switch (y->ts.type)
1820 : : {
1821 : 3522 : case BT_INTEGER:
1822 : 3522 : mpfr_set_z (mpc_imagref (result->value.complex),
1823 : 3522 : y->value.integer, GFC_RND_MODE);
1824 : 3522 : break;
1825 : :
1826 : 1427 : case BT_REAL:
1827 : 1427 : mpfr_set (mpc_imagref (result->value.complex),
1828 : : y->value.real, GFC_RND_MODE);
1829 : 1427 : break;
1830 : :
1831 : 0 : default:
1832 : 0 : gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1833 : : }
1834 : :
1835 : 4949 : return range_check (result, name);
1836 : : }
1837 : :
1838 : :
1839 : : gfc_expr *
1840 : 6461 : gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1841 : : {
1842 : 6461 : int kind;
1843 : :
1844 : 6461 : kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
1845 : 6461 : if (kind == -1)
1846 : : return &gfc_bad_expr;
1847 : :
1848 : 6461 : return simplify_cmplx ("CMPLX", x, y, kind);
1849 : : }
1850 : :
1851 : :
1852 : : gfc_expr *
1853 : 55 : gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
1854 : : {
1855 : 55 : int kind;
1856 : :
1857 : 55 : if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
1858 : 15 : kind = gfc_default_complex_kind;
1859 : 40 : else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
1860 : 34 : kind = x->ts.kind;
1861 : 6 : else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
1862 : 6 : kind = y->ts.kind;
1863 : 0 : else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
1864 : : kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
1865 : : else
1866 : 0 : gcc_unreachable ();
1867 : :
1868 : 55 : return simplify_cmplx ("COMPLEX", x, y, kind);
1869 : : }
1870 : :
1871 : :
1872 : : gfc_expr *
1873 : 720 : gfc_simplify_conjg (gfc_expr *e)
1874 : : {
1875 : 720 : gfc_expr *result;
1876 : :
1877 : 720 : if (e->expr_type != EXPR_CONSTANT)
1878 : : return NULL;
1879 : :
1880 : 47 : result = gfc_copy_expr (e);
1881 : 47 : mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
1882 : :
1883 : 47 : return range_check (result, "CONJG");
1884 : : }
1885 : :
1886 : :
1887 : : /* Simplify atan2d (x) where the unit is degree. */
1888 : :
1889 : : gfc_expr *
1890 : 168 : gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
1891 : : {
1892 : 168 : gfc_expr *result;
1893 : :
1894 : 168 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
1895 : : return NULL;
1896 : :
1897 : 24 : if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
1898 : : {
1899 : 0 : gfc_error ("If first argument of ATAN2D at %L is zero, then the "
1900 : : "second argument must not be zero", &y->where);
1901 : 0 : return &gfc_bad_expr;
1902 : : }
1903 : :
1904 : 24 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1905 : 24 : mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
1906 : 24 : rad2deg (result->value.real);
1907 : :
1908 : 24 : return range_check (result, "ATAN2D");
1909 : : }
1910 : :
1911 : :
1912 : : gfc_expr *
1913 : 916 : gfc_simplify_cos (gfc_expr *x)
1914 : : {
1915 : 916 : gfc_expr *result;
1916 : :
1917 : 916 : if (x->expr_type != EXPR_CONSTANT)
1918 : : return NULL;
1919 : :
1920 : 162 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1921 : :
1922 : 162 : switch (x->ts.type)
1923 : : {
1924 : 105 : case BT_REAL:
1925 : 105 : mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1926 : 105 : break;
1927 : :
1928 : 57 : case BT_COMPLEX:
1929 : 57 : gfc_set_model_kind (x->ts.kind);
1930 : 57 : mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1931 : 57 : break;
1932 : :
1933 : 0 : default:
1934 : 0 : gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1935 : : }
1936 : :
1937 : 162 : return range_check (result, "COS");
1938 : : }
1939 : :
1940 : :
1941 : : static void
1942 : 48 : deg2rad (mpfr_t x)
1943 : : {
1944 : 48 : mpfr_t d2r;
1945 : :
1946 : 48 : mpfr_init (d2r);
1947 : 48 : mpfr_const_pi (d2r, GFC_RND_MODE);
1948 : 48 : mpfr_div_ui (d2r, d2r, 180, GFC_RND_MODE);
1949 : 48 : mpfr_mul (x, x, d2r, GFC_RND_MODE);
1950 : 48 : mpfr_clear (d2r);
1951 : 48 : }
1952 : :
1953 : :
1954 : : /* Simplification routines for SIND, COSD, TAND. */
1955 : : #include "trigd_fe.inc"
1956 : :
1957 : :
1958 : : /* Simplify COSD(X) where X has the unit of degree. */
1959 : :
1960 : : gfc_expr *
1961 : 181 : gfc_simplify_cosd (gfc_expr *x)
1962 : : {
1963 : 181 : gfc_expr *result;
1964 : :
1965 : 181 : if (x->expr_type != EXPR_CONSTANT)
1966 : : return NULL;
1967 : :
1968 : 25 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1969 : 25 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
1970 : 25 : simplify_cosd (result->value.real);
1971 : :
1972 : 25 : return range_check (result, "COSD");
1973 : : }
1974 : :
1975 : :
1976 : : /* Simplify SIND(X) where X has the unit of degree. */
1977 : :
1978 : : gfc_expr *
1979 : 181 : gfc_simplify_sind (gfc_expr *x)
1980 : : {
1981 : 181 : gfc_expr *result;
1982 : :
1983 : 181 : if (x->expr_type != EXPR_CONSTANT)
1984 : : return NULL;
1985 : :
1986 : 25 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1987 : 25 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
1988 : 25 : simplify_sind (result->value.real);
1989 : :
1990 : 25 : return range_check (result, "SIND");
1991 : : }
1992 : :
1993 : :
1994 : : /* Simplify TAND(X) where X has the unit of degree. */
1995 : :
1996 : : gfc_expr *
1997 : 265 : gfc_simplify_tand (gfc_expr *x)
1998 : : {
1999 : 265 : gfc_expr *result;
2000 : :
2001 : 265 : if (x->expr_type != EXPR_CONSTANT)
2002 : : return NULL;
2003 : :
2004 : 25 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2005 : 25 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
2006 : 25 : simplify_tand (result->value.real);
2007 : :
2008 : 25 : return range_check (result, "TAND");
2009 : : }
2010 : :
2011 : :
2012 : : /* Simplify COTAND(X) where X has the unit of degree. */
2013 : :
2014 : : gfc_expr *
2015 : 241 : gfc_simplify_cotand (gfc_expr *x)
2016 : : {
2017 : 241 : gfc_expr *result;
2018 : :
2019 : 241 : if (x->expr_type != EXPR_CONSTANT)
2020 : : return NULL;
2021 : :
2022 : : /* Implement COTAND = -TAND(x+90).
2023 : : TAND offers correct exact values for multiples of 30 degrees.
2024 : : This implementation is also compatible with the behavior of some legacy
2025 : : compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */
2026 : 25 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2027 : 25 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
2028 : 25 : mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODE);
2029 : 25 : simplify_tand (result->value.real);
2030 : 25 : mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
2031 : :
2032 : 25 : return range_check (result, "COTAND");
2033 : : }
2034 : :
2035 : :
2036 : : gfc_expr *
2037 : 317 : gfc_simplify_cosh (gfc_expr *x)
2038 : : {
2039 : 317 : gfc_expr *result;
2040 : :
2041 : 317 : if (x->expr_type != EXPR_CONSTANT)
2042 : : return NULL;
2043 : :
2044 : 47 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2045 : :
2046 : 47 : switch (x->ts.type)
2047 : : {
2048 : 43 : case BT_REAL:
2049 : 43 : mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
2050 : 43 : break;
2051 : :
2052 : 4 : case BT_COMPLEX:
2053 : 4 : mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
2054 : 4 : break;
2055 : :
2056 : 0 : default:
2057 : 0 : gcc_unreachable ();
2058 : : }
2059 : :
2060 : 47 : return range_check (result, "COSH");
2061 : : }
2062 : :
2063 : :
2064 : : gfc_expr *
2065 : 440 : gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
2066 : : {
2067 : 440 : gfc_expr *result;
2068 : 440 : bool size_zero;
2069 : :
2070 : 440 : size_zero = gfc_is_size_zero_array (mask);
2071 : :
2072 : 825 : if (!(is_constant_array_expr (mask) || size_zero)
2073 : 55 : || !gfc_is_constant_expr (dim)
2074 : 495 : || !gfc_is_constant_expr (kind))
2075 : 385 : return NULL;
2076 : :
2077 : 55 : result = transformational_result (mask, dim,
2078 : : BT_INTEGER,
2079 : : get_kind (BT_INTEGER, kind, "COUNT",
2080 : : gfc_default_integer_kind),
2081 : : &mask->where);
2082 : :
2083 : 55 : init_result_expr (result, 0, NULL);
2084 : :
2085 : 55 : if (size_zero)
2086 : : return result;
2087 : :
2088 : : /* Passing MASK twice, once as data array, once as mask.
2089 : : Whenever gfc_count is called, '1' is added to the result. */
2090 : 30 : return !dim || mask->rank == 1 ?
2091 : 24 : simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
2092 : 6 : simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
2093 : : }
2094 : :
2095 : : /* Simplification routine for cshift. This works by copying the array
2096 : : expressions into a one-dimensional array, shuffling the values into another
2097 : : one-dimensional array and creating the new array expression from this. The
2098 : : shuffling part is basically taken from the library routine. */
2099 : :
2100 : : gfc_expr *
2101 : 921 : gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
2102 : : {
2103 : 921 : gfc_expr *result;
2104 : 921 : int which;
2105 : 921 : gfc_expr **arrayvec, **resultvec;
2106 : 921 : gfc_expr **rptr, **sptr;
2107 : 921 : mpz_t size;
2108 : 921 : size_t arraysize, shiftsize, i;
2109 : 921 : gfc_constructor *array_ctor, *shift_ctor;
2110 : 921 : ssize_t *shiftvec, *hptr;
2111 : 921 : ssize_t shift_val, len;
2112 : 921 : ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
2113 : : hs_ex[GFC_MAX_DIMENSIONS + 1],
2114 : : hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS],
2115 : : a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS],
2116 : : h_extent[GFC_MAX_DIMENSIONS],
2117 : : ss_ex[GFC_MAX_DIMENSIONS + 1];
2118 : 921 : ssize_t rsoffset;
2119 : 921 : int d, n;
2120 : 921 : bool continue_loop;
2121 : 921 : gfc_expr **src, **dest;
2122 : :
2123 : 921 : if (!is_constant_array_expr (array))
2124 : : return NULL;
2125 : :
2126 : 68 : if (shift->rank > 0)
2127 : 3 : gfc_simplify_expr (shift, 1);
2128 : :
2129 : 68 : if (!gfc_is_constant_expr (shift))
2130 : : return NULL;
2131 : :
2132 : : /* Make dim zero-based. */
2133 : 68 : if (dim)
2134 : : {
2135 : 19 : if (!gfc_is_constant_expr (dim))
2136 : : return NULL;
2137 : 7 : which = mpz_get_si (dim->value.integer) - 1;
2138 : : }
2139 : : else
2140 : : which = 0;
2141 : :
2142 : 56 : if (array->shape == NULL)
2143 : : return NULL;
2144 : :
2145 : 56 : gfc_array_size (array, &size);
2146 : 56 : arraysize = mpz_get_ui (size);
2147 : 56 : mpz_clear (size);
2148 : :
2149 : 56 : result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
2150 : 56 : result->shape = gfc_copy_shape (array->shape, array->rank);
2151 : 56 : result->rank = array->rank;
2152 : 56 : result->ts.u.derived = array->ts.u.derived;
2153 : :
2154 : 56 : if (arraysize == 0)
2155 : : return result;
2156 : :
2157 : 55 : arrayvec = XCNEWVEC (gfc_expr *, arraysize);
2158 : 55 : array_ctor = gfc_constructor_first (array->value.constructor);
2159 : 889 : for (i = 0; i < arraysize; i++)
2160 : : {
2161 : 779 : arrayvec[i] = array_ctor->expr;
2162 : 779 : array_ctor = gfc_constructor_next (array_ctor);
2163 : : }
2164 : :
2165 : 55 : resultvec = XCNEWVEC (gfc_expr *, arraysize);
2166 : :
2167 : 55 : sstride[0] = 0;
2168 : 55 : extent[0] = 1;
2169 : 55 : count[0] = 0;
2170 : :
2171 : 131 : for (d=0; d < array->rank; d++)
2172 : : {
2173 : 76 : a_extent[d] = mpz_get_si (array->shape[d]);
2174 : 76 : a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
2175 : : }
2176 : :
2177 : 55 : if (shift->rank > 0)
2178 : : {
2179 : 3 : gfc_array_size (shift, &size);
2180 : 3 : shiftsize = mpz_get_ui (size);
2181 : 3 : mpz_clear (size);
2182 : 3 : shiftvec = XCNEWVEC (ssize_t, shiftsize);
2183 : 3 : shift_ctor = gfc_constructor_first (shift->value.constructor);
2184 : 12 : for (d = 0; d < shift->rank; d++)
2185 : : {
2186 : 6 : h_extent[d] = mpz_get_si (shift->shape[d]);
2187 : 6 : hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1];
2188 : : }
2189 : : }
2190 : : else
2191 : : shiftvec = NULL;
2192 : :
2193 : : /* Shut up compiler */
2194 : 55 : len = 1;
2195 : 55 : rsoffset = 1;
2196 : :
2197 : 55 : n = 0;
2198 : 131 : for (d=0; d < array->rank; d++)
2199 : : {
2200 : 76 : if (d == which)
2201 : : {
2202 : 55 : rsoffset = a_stride[d];
2203 : 55 : len = a_extent[d];
2204 : : }
2205 : : else
2206 : : {
2207 : 21 : count[n] = 0;
2208 : 21 : extent[n] = a_extent[d];
2209 : 21 : sstride[n] = a_stride[d];
2210 : 21 : ss_ex[n] = sstride[n] * extent[n];
2211 : 21 : if (shiftvec)
2212 : 6 : hs_ex[n] = hstride[n] * extent[n];
2213 : 21 : n++;
2214 : : }
2215 : : }
2216 : 55 : ss_ex[n] = 0;
2217 : 55 : hs_ex[n] = 0;
2218 : :
2219 : 55 : if (shiftvec)
2220 : : {
2221 : 50 : for (i = 0; i < shiftsize; i++)
2222 : : {
2223 : 47 : ssize_t val;
2224 : 47 : val = mpz_get_si (shift_ctor->expr->value.integer);
2225 : 47 : val = val % len;
2226 : 47 : if (val < 0)
2227 : 12 : val += len;
2228 : 47 : shiftvec[i] = val;
2229 : 47 : shift_ctor = gfc_constructor_next (shift_ctor);
2230 : : }
2231 : : shift_val = 0;
2232 : : }
2233 : : else
2234 : : {
2235 : 52 : shift_val = mpz_get_si (shift->value.integer);
2236 : 52 : shift_val = shift_val % len;
2237 : 52 : if (shift_val < 0)
2238 : 6 : shift_val += len;
2239 : : }
2240 : :
2241 : 55 : continue_loop = true;
2242 : 55 : d = array->rank;
2243 : 55 : rptr = resultvec;
2244 : 55 : sptr = arrayvec;
2245 : 55 : hptr = shiftvec;
2246 : :
2247 : 311 : while (continue_loop)
2248 : : {
2249 : 201 : ssize_t sh;
2250 : 201 : if (shiftvec)
2251 : 47 : sh = *hptr;
2252 : : else
2253 : : sh = shift_val;
2254 : :
2255 : 201 : src = &sptr[sh * rsoffset];
2256 : 201 : dest = rptr;
2257 : 735 : for (n = 0; n < len - sh; n++)
2258 : : {
2259 : 534 : *dest = *src;
2260 : 534 : dest += rsoffset;
2261 : 534 : src += rsoffset;
2262 : : }
2263 : : src = sptr;
2264 : 446 : for ( n = 0; n < sh; n++)
2265 : : {
2266 : 245 : *dest = *src;
2267 : 245 : dest += rsoffset;
2268 : 245 : src += rsoffset;
2269 : : }
2270 : 201 : rptr += sstride[0];
2271 : 201 : sptr += sstride[0];
2272 : 201 : if (shiftvec)
2273 : 47 : hptr += hstride[0];
2274 : 201 : count[0]++;
2275 : 201 : n = 0;
2276 : 244 : while (count[n] == extent[n])
2277 : : {
2278 : 98 : count[n] = 0;
2279 : 98 : rptr -= ss_ex[n];
2280 : 98 : sptr -= ss_ex[n];
2281 : 98 : if (shiftvec)
2282 : 17 : hptr -= hs_ex[n];
2283 : 98 : n++;
2284 : 98 : if (n >= d - 1)
2285 : : {
2286 : : continue_loop = false;
2287 : : break;
2288 : : }
2289 : : else
2290 : : {
2291 : 43 : count[n]++;
2292 : 43 : rptr += sstride[n];
2293 : 43 : sptr += sstride[n];
2294 : 43 : if (shiftvec)
2295 : 14 : hptr += hstride[n];
2296 : : }
2297 : : }
2298 : : }
2299 : :
2300 : 834 : for (i = 0; i < arraysize; i++)
2301 : : {
2302 : 779 : gfc_constructor_append_expr (&result->value.constructor,
2303 : 779 : gfc_copy_expr (resultvec[i]),
2304 : : NULL);
2305 : : }
2306 : : return result;
2307 : : }
2308 : :
2309 : :
2310 : : gfc_expr *
2311 : 299 : gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
2312 : : {
2313 : 299 : return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
2314 : : }
2315 : :
2316 : :
2317 : : gfc_expr *
2318 : 620 : gfc_simplify_dble (gfc_expr *e)
2319 : : {
2320 : 620 : gfc_expr *result = NULL;
2321 : 620 : int tmp1, tmp2;
2322 : :
2323 : 620 : if (e->expr_type != EXPR_CONSTANT)
2324 : : return NULL;
2325 : :
2326 : : /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
2327 : : warnings. */
2328 : 119 : tmp1 = warn_conversion;
2329 : 119 : tmp2 = warn_conversion_extra;
2330 : 119 : warn_conversion = warn_conversion_extra = 0;
2331 : :
2332 : 119 : result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
2333 : :
2334 : 119 : warn_conversion = tmp1;
2335 : 119 : warn_conversion_extra = tmp2;
2336 : :
2337 : 119 : if (result == &gfc_bad_expr)
2338 : : return &gfc_bad_expr;
2339 : :
2340 : 119 : return range_check (result, "DBLE");
2341 : : }
2342 : :
2343 : :
2344 : : gfc_expr *
2345 : 34 : gfc_simplify_digits (gfc_expr *x)
2346 : : {
2347 : 34 : int i, digits;
2348 : :
2349 : 34 : i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2350 : :
2351 : 34 : switch (x->ts.type)
2352 : : {
2353 : 1 : case BT_INTEGER:
2354 : 1 : digits = gfc_integer_kinds[i].digits;
2355 : 1 : break;
2356 : :
2357 : 33 : case BT_REAL:
2358 : 33 : case BT_COMPLEX:
2359 : 33 : digits = gfc_real_kinds[i].digits;
2360 : 33 : break;
2361 : :
2362 : 0 : default:
2363 : 0 : gcc_unreachable ();
2364 : : }
2365 : :
2366 : 34 : return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
2367 : : }
2368 : :
2369 : :
2370 : : gfc_expr *
2371 : 324 : gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
2372 : : {
2373 : 324 : gfc_expr *result;
2374 : 324 : int kind;
2375 : :
2376 : 324 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2377 : : return NULL;
2378 : :
2379 : 78 : kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2380 : 78 : result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
2381 : :
2382 : 78 : switch (x->ts.type)
2383 : : {
2384 : 36 : case BT_INTEGER:
2385 : 36 : if (mpz_cmp (x->value.integer, y->value.integer) > 0)
2386 : 15 : mpz_sub (result->value.integer, x->value.integer, y->value.integer);
2387 : : else
2388 : 21 : mpz_set_ui (result->value.integer, 0);
2389 : :
2390 : : break;
2391 : :
2392 : 42 : case BT_REAL:
2393 : 42 : if (mpfr_cmp (x->value.real, y->value.real) > 0)
2394 : 30 : mpfr_sub (result->value.real, x->value.real, y->value.real,
2395 : : GFC_RND_MODE);
2396 : : else
2397 : 12 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2398 : :
2399 : : break;
2400 : :
2401 : 0 : default:
2402 : 0 : gfc_internal_error ("gfc_simplify_dim(): Bad type");
2403 : : }
2404 : :
2405 : 78 : return range_check (result, "DIM");
2406 : : }
2407 : :
2408 : :
2409 : : gfc_expr*
2410 : 222 : gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
2411 : : {
2412 : : /* If vector_a is a zero-sized array, the result is 0 for INTEGER,
2413 : : REAL, and COMPLEX types and .false. for LOGICAL. */
2414 : 222 : if (vector_a->shape && mpz_get_si (vector_a->shape[0]) == 0)
2415 : : {
2416 : 30 : if (vector_a->ts.type == BT_LOGICAL)
2417 : 6 : return gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
2418 : : else
2419 : 24 : return gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
2420 : : }
2421 : :
2422 : 192 : if (!is_constant_array_expr (vector_a)
2423 : 192 : || !is_constant_array_expr (vector_b))
2424 : 164 : return NULL;
2425 : :
2426 : 28 : return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true);
2427 : : }
2428 : :
2429 : :
2430 : : gfc_expr *
2431 : 34 : gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
2432 : : {
2433 : 34 : gfc_expr *a1, *a2, *result;
2434 : :
2435 : 34 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2436 : : return NULL;
2437 : :
2438 : 6 : a1 = gfc_real2real (x, gfc_default_double_kind);
2439 : 6 : a2 = gfc_real2real (y, gfc_default_double_kind);
2440 : :
2441 : 6 : result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
2442 : 6 : mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
2443 : :
2444 : 6 : gfc_free_expr (a2);
2445 : 6 : gfc_free_expr (a1);
2446 : :
2447 : 6 : return range_check (result, "DPROD");
2448 : : }
2449 : :
2450 : :
2451 : : static gfc_expr *
2452 : 1600 : simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
2453 : : bool right)
2454 : : {
2455 : 1600 : gfc_expr *result;
2456 : 1600 : int i, k, size, shift;
2457 : :
2458 : 1600 : if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
2459 : 1464 : || shiftarg->expr_type != EXPR_CONSTANT)
2460 : : return NULL;
2461 : :
2462 : 1464 : k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
2463 : 1464 : size = gfc_integer_kinds[k].bit_size;
2464 : :
2465 : 1464 : gfc_extract_int (shiftarg, &shift);
2466 : :
2467 : : /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2468 : 1464 : if (right)
2469 : 732 : shift = size - shift;
2470 : :
2471 : 1464 : result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
2472 : 1464 : mpz_set_ui (result->value.integer, 0);
2473 : :
2474 : 39024 : for (i = 0; i < shift; i++)
2475 : 36096 : if (mpz_tstbit (arg2->value.integer, size - shift + i))
2476 : 15006 : mpz_setbit (result->value.integer, i);
2477 : :
2478 : 37560 : for (i = 0; i < size - shift; i++)
2479 : 36096 : if (mpz_tstbit (arg1->value.integer, i))
2480 : 14400 : mpz_setbit (result->value.integer, shift + i);
2481 : :
2482 : : /* Convert to a signed value. */
2483 : 1464 : gfc_convert_mpz_to_signed (result->value.integer, size);
2484 : :
2485 : 1464 : return result;
2486 : : }
2487 : :
2488 : :
2489 : : gfc_expr *
2490 : 800 : gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2491 : : {
2492 : 800 : return simplify_dshift (arg1, arg2, shiftarg, true);
2493 : : }
2494 : :
2495 : :
2496 : : gfc_expr *
2497 : 800 : gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2498 : : {
2499 : 800 : return simplify_dshift (arg1, arg2, shiftarg, false);
2500 : : }
2501 : :
2502 : :
2503 : : gfc_expr *
2504 : 1514 : gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
2505 : : gfc_expr *dim)
2506 : : {
2507 : 1514 : bool temp_boundary;
2508 : 1514 : gfc_expr *bnd;
2509 : 1514 : gfc_expr *result;
2510 : 1514 : int which;
2511 : 1514 : gfc_expr **arrayvec, **resultvec;
2512 : 1514 : gfc_expr **rptr, **sptr;
2513 : 1514 : mpz_t size;
2514 : 1514 : size_t arraysize, i;
2515 : 1514 : gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor;
2516 : 1514 : ssize_t shift_val, len;
2517 : 1514 : ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
2518 : : sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS],
2519 : : a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS + 1];
2520 : 1514 : ssize_t rsoffset;
2521 : 1514 : int d, n;
2522 : 1514 : bool continue_loop;
2523 : 1514 : gfc_expr **src, **dest;
2524 : 1514 : size_t s_len;
2525 : :
2526 : 1514 : if (!is_constant_array_expr (array))
2527 : : return NULL;
2528 : :
2529 : 48 : if (shift->rank > 0)
2530 : 7 : gfc_simplify_expr (shift, 1);
2531 : :
2532 : 48 : if (!gfc_is_constant_expr (shift))
2533 : : return NULL;
2534 : :
2535 : 48 : if (boundary)
2536 : : {
2537 : 23 : if (boundary->rank > 0)
2538 : 6 : gfc_simplify_expr (boundary, 1);
2539 : :
2540 : 23 : if (!gfc_is_constant_expr (boundary))
2541 : : return NULL;
2542 : : }
2543 : :
2544 : 36 : if (dim)
2545 : : {
2546 : 19 : if (!gfc_is_constant_expr (dim))
2547 : : return NULL;
2548 : 13 : which = mpz_get_si (dim->value.integer) - 1;
2549 : : }
2550 : : else
2551 : : which = 0;
2552 : :
2553 : 30 : s_len = 0;
2554 : 30 : if (boundary == NULL)
2555 : : {
2556 : 23 : temp_boundary = true;
2557 : 23 : switch (array->ts.type)
2558 : : {
2559 : :
2560 : 17 : case BT_INTEGER:
2561 : 17 : bnd = gfc_get_int_expr (array->ts.kind, NULL, 0);
2562 : 17 : break;
2563 : :
2564 : 0 : case BT_LOGICAL:
2565 : 0 : bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0);
2566 : 0 : break;
2567 : :
2568 : 2 : case BT_REAL:
2569 : 2 : bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
2570 : 2 : mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE);
2571 : 2 : break;
2572 : :
2573 : 1 : case BT_COMPLEX:
2574 : 1 : bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
2575 : 1 : mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE);
2576 : 1 : break;
2577 : :
2578 : 3 : case BT_CHARACTER:
2579 : 3 : s_len = mpz_get_ui (array->ts.u.cl->length->value.integer);
2580 : 3 : bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, s_len);
2581 : 3 : break;
2582 : :
2583 : 0 : default:
2584 : 0 : gcc_unreachable();
2585 : :
2586 : : }
2587 : : }
2588 : : else
2589 : : {
2590 : : temp_boundary = false;
2591 : : bnd = boundary;
2592 : : }
2593 : :
2594 : 30 : gfc_array_size (array, &size);
2595 : 30 : arraysize = mpz_get_ui (size);
2596 : 30 : mpz_clear (size);
2597 : :
2598 : 30 : result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
2599 : 30 : result->shape = gfc_copy_shape (array->shape, array->rank);
2600 : 30 : result->rank = array->rank;
2601 : 30 : result->ts = array->ts;
2602 : :
2603 : 30 : if (arraysize == 0)
2604 : 1 : goto final;
2605 : :
2606 : 29 : if (array->shape == NULL)
2607 : 1 : goto final;
2608 : :
2609 : 28 : arrayvec = XCNEWVEC (gfc_expr *, arraysize);
2610 : 28 : array_ctor = gfc_constructor_first (array->value.constructor);
2611 : 440 : for (i = 0; i < arraysize; i++)
2612 : : {
2613 : 384 : arrayvec[i] = array_ctor->expr;
2614 : 384 : array_ctor = gfc_constructor_next (array_ctor);
2615 : : }
2616 : :
2617 : 28 : resultvec = XCNEWVEC (gfc_expr *, arraysize);
2618 : :
2619 : 28 : extent[0] = 1;
2620 : 28 : count[0] = 0;
2621 : :
2622 : 80 : for (d=0; d < array->rank; d++)
2623 : : {
2624 : 52 : a_extent[d] = mpz_get_si (array->shape[d]);
2625 : 52 : a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
2626 : : }
2627 : :
2628 : 28 : if (shift->rank > 0)
2629 : : {
2630 : 7 : shift_ctor = gfc_constructor_first (shift->value.constructor);
2631 : 7 : shift_val = 0;
2632 : : }
2633 : : else
2634 : : {
2635 : 21 : shift_ctor = NULL;
2636 : 21 : shift_val = mpz_get_si (shift->value.integer);
2637 : : }
2638 : :
2639 : 28 : if (bnd->rank > 0)
2640 : 4 : bnd_ctor = gfc_constructor_first (bnd->value.constructor);
2641 : : else
2642 : : bnd_ctor = NULL;
2643 : :
2644 : : /* Shut up compiler */
2645 : 28 : len = 1;
2646 : 28 : rsoffset = 1;
2647 : :
2648 : 28 : n = 0;
2649 : 80 : for (d=0; d < array->rank; d++)
2650 : : {
2651 : 52 : if (d == which)
2652 : : {
2653 : 28 : rsoffset = a_stride[d];
2654 : 28 : len = a_extent[d];
2655 : : }
2656 : : else
2657 : : {
2658 : 24 : count[n] = 0;
2659 : 24 : extent[n] = a_extent[d];
2660 : 24 : sstride[n] = a_stride[d];
2661 : 24 : ss_ex[n] = sstride[n] * extent[n];
2662 : 24 : n++;
2663 : : }
2664 : : }
2665 : 28 : ss_ex[n] = 0;
2666 : :
2667 : 28 : continue_loop = true;
2668 : 28 : d = array->rank;
2669 : 28 : rptr = resultvec;
2670 : 28 : sptr = arrayvec;
2671 : :
2672 : 136 : while (continue_loop)
2673 : : {
2674 : 108 : ssize_t sh, delta;
2675 : :
2676 : 108 : if (shift_ctor)
2677 : 42 : sh = mpz_get_si (shift_ctor->expr->value.integer);
2678 : : else
2679 : : sh = shift_val;
2680 : :
2681 : 108 : if (( sh >= 0 ? sh : -sh ) > len)
2682 : : {
2683 : : delta = len;
2684 : : sh = len;
2685 : : }
2686 : : else
2687 : 94 : delta = (sh >= 0) ? sh: -sh;
2688 : :
2689 : 108 : if (sh > 0)
2690 : : {
2691 : 63 : src = &sptr[delta * rsoffset];
2692 : 63 : dest = rptr;
2693 : : }
2694 : : else
2695 : : {
2696 : 45 : src = sptr;
2697 : 45 : dest = &rptr[delta * rsoffset];
2698 : : }
2699 : :
2700 : 321 : for (n = 0; n < len - delta; n++)
2701 : : {
2702 : 213 : *dest = *src;
2703 : 213 : dest += rsoffset;
2704 : 213 : src += rsoffset;
2705 : : }
2706 : :
2707 : 108 : if (sh < 0)
2708 : 39 : dest = rptr;
2709 : :
2710 : 108 : n = delta;
2711 : :
2712 : 108 : if (bnd_ctor)
2713 : : {
2714 : 73 : while (n--)
2715 : : {
2716 : 47 : *dest = gfc_copy_expr (bnd_ctor->expr);
2717 : 47 : dest += rsoffset;
2718 : : }
2719 : : }
2720 : : else
2721 : : {
2722 : 206 : while (n--)
2723 : : {
2724 : 124 : *dest = gfc_copy_expr (bnd);
2725 : 124 : dest += rsoffset;
2726 : : }
2727 : : }
2728 : 108 : rptr += sstride[0];
2729 : 108 : sptr += sstride[0];
2730 : 108 : if (shift_ctor)
2731 : 42 : shift_ctor = gfc_constructor_next (shift_ctor);
2732 : :
2733 : 108 : if (bnd_ctor)
2734 : 26 : bnd_ctor = gfc_constructor_next (bnd_ctor);
2735 : :
2736 : 108 : count[0]++;
2737 : 108 : n = 0;
2738 : 131 : while (count[n] == extent[n])
2739 : : {
2740 : 51 : count[n] = 0;
2741 : 51 : rptr -= ss_ex[n];
2742 : 51 : sptr -= ss_ex[n];
2743 : 51 : n++;
2744 : 51 : if (n >= d - 1)
2745 : : {
2746 : : continue_loop = false;
2747 : : break;
2748 : : }
2749 : : else
2750 : : {
2751 : 23 : count[n]++;
2752 : 23 : rptr += sstride[n];
2753 : 23 : sptr += sstride[n];
2754 : : }
2755 : : }
2756 : : }
2757 : :
2758 : 412 : for (i = 0; i < arraysize; i++)
2759 : : {
2760 : 384 : gfc_constructor_append_expr (&result->value.constructor,
2761 : 384 : gfc_copy_expr (resultvec[i]),
2762 : : NULL);
2763 : : }
2764 : :
2765 : 28 : final:
2766 : 30 : if (temp_boundary)
2767 : 23 : gfc_free_expr (bnd);
2768 : :
2769 : : return result;
2770 : : }
2771 : :
2772 : : gfc_expr *
2773 : 169 : gfc_simplify_erf (gfc_expr *x)
2774 : : {
2775 : 169 : gfc_expr *result;
2776 : :
2777 : 169 : if (x->expr_type != EXPR_CONSTANT)
2778 : : return NULL;
2779 : :
2780 : 35 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2781 : 35 : mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
2782 : :
2783 : 35 : return range_check (result, "ERF");
2784 : : }
2785 : :
2786 : :
2787 : : gfc_expr *
2788 : 242 : gfc_simplify_erfc (gfc_expr *x)
2789 : : {
2790 : 242 : gfc_expr *result;
2791 : :
2792 : 242 : if (x->expr_type != EXPR_CONSTANT)
2793 : : return NULL;
2794 : :
2795 : 36 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2796 : 36 : mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
2797 : :
2798 : 36 : return range_check (result, "ERFC");
2799 : : }
2800 : :
2801 : :
2802 : : /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2803 : :
2804 : : #define MAX_ITER 200
2805 : : #define ARG_LIMIT 12
2806 : :
2807 : : /* Calculate ERFC_SCALED directly by its definition:
2808 : :
2809 : : ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2810 : :
2811 : : using a large precision for intermediate results. This is used for all
2812 : : but large values of the argument. */
2813 : : static void
2814 : 39 : fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
2815 : : {
2816 : 39 : mpfr_prec_t prec;
2817 : 39 : mpfr_t a, b;
2818 : :
2819 : 39 : prec = mpfr_get_default_prec ();
2820 : 39 : mpfr_set_default_prec (10 * prec);
2821 : :
2822 : 39 : mpfr_init (a);
2823 : 39 : mpfr_init (b);
2824 : :
2825 : 39 : mpfr_set (a, arg, GFC_RND_MODE);
2826 : 39 : mpfr_sqr (b, a, GFC_RND_MODE);
2827 : 39 : mpfr_exp (b, b, GFC_RND_MODE);
2828 : 39 : mpfr_erfc (a, a, GFC_RND_MODE);
2829 : 39 : mpfr_mul (a, a, b, GFC_RND_MODE);
2830 : :
2831 : 39 : mpfr_set (res, a, GFC_RND_MODE);
2832 : 39 : mpfr_set_default_prec (prec);
2833 : :
2834 : 39 : mpfr_clear (a);
2835 : 39 : mpfr_clear (b);
2836 : 39 : }
2837 : :
2838 : : /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2839 : :
2840 : : ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2841 : : * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2842 : : / (2 * x**2)**n)
2843 : :
2844 : : This is used for large values of the argument. Intermediate calculations
2845 : : are performed with twice the precision. We don't do a fixed number of
2846 : : iterations of the sum, but stop when it has converged to the required
2847 : : precision. */
2848 : : static void
2849 : 10 : asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
2850 : : {
2851 : 10 : mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
2852 : 10 : mpz_t num;
2853 : 10 : mpfr_prec_t prec;
2854 : 10 : unsigned i;
2855 : :
2856 : 10 : prec = mpfr_get_default_prec ();
2857 : 10 : mpfr_set_default_prec (2 * prec);
2858 : :
2859 : 10 : mpfr_init (sum);
2860 : 10 : mpfr_init (x);
2861 : 10 : mpfr_init (u);
2862 : 10 : mpfr_init (v);
2863 : 10 : mpfr_init (w);
2864 : 10 : mpz_init (num);
2865 : :
2866 : 10 : mpfr_init (oldsum);
2867 : 10 : mpfr_init (sumtrunc);
2868 : 10 : mpfr_set_prec (oldsum, prec);
2869 : 10 : mpfr_set_prec (sumtrunc, prec);
2870 : :
2871 : 10 : mpfr_set (x, arg, GFC_RND_MODE);
2872 : 10 : mpfr_set_ui (sum, 1, GFC_RND_MODE);
2873 : 10 : mpz_set_ui (num, 1);
2874 : :
2875 : 10 : mpfr_set (u, x, GFC_RND_MODE);
2876 : 10 : mpfr_sqr (u, u, GFC_RND_MODE);
2877 : 10 : mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
2878 : 10 : mpfr_pow_si (u, u, -1, GFC_RND_MODE);
2879 : :
2880 : 132 : for (i = 1; i < MAX_ITER; i++)
2881 : : {
2882 : 132 : mpfr_set (oldsum, sum, GFC_RND_MODE);
2883 : :
2884 : 132 : mpz_mul_ui (num, num, 2 * i - 1);
2885 : 132 : mpz_neg (num, num);
2886 : :
2887 : 132 : mpfr_set (w, u, GFC_RND_MODE);
2888 : 132 : mpfr_pow_ui (w, w, i, GFC_RND_MODE);
2889 : :
2890 : 132 : mpfr_set_z (v, num, GFC_RND_MODE);
2891 : 132 : mpfr_mul (v, v, w, GFC_RND_MODE);
2892 : :
2893 : 132 : mpfr_add (sum, sum, v, GFC_RND_MODE);
2894 : :
2895 : 132 : mpfr_set (sumtrunc, sum, GFC_RND_MODE);
2896 : 132 : if (mpfr_cmp (sumtrunc, oldsum) == 0)
2897 : : break;
2898 : : }
2899 : :
2900 : : /* We should have converged by now; otherwise, ARG_LIMIT is probably
2901 : : set too low. */
2902 : 10 : gcc_assert (i < MAX_ITER);
2903 : :
2904 : : /* Divide by x * sqrt(Pi). */
2905 : 10 : mpfr_const_pi (u, GFC_RND_MODE);
2906 : 10 : mpfr_sqrt (u, u, GFC_RND_MODE);
2907 : 10 : mpfr_mul (u, u, x, GFC_RND_MODE);
2908 : 10 : mpfr_div (sum, sum, u, GFC_RND_MODE);
2909 : :
2910 : 10 : mpfr_set (res, sum, GFC_RND_MODE);
2911 : 10 : mpfr_set_default_prec (prec);
2912 : :
2913 : 10 : mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
2914 : 10 : mpz_clear (num);
2915 : 10 : }
2916 : :
2917 : :
2918 : : gfc_expr *
2919 : 143 : gfc_simplify_erfc_scaled (gfc_expr *x)
2920 : : {
2921 : 143 : gfc_expr *result;
2922 : :
2923 : 143 : if (x->expr_type != EXPR_CONSTANT)
2924 : : return NULL;
2925 : :
2926 : 49 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2927 : 49 : if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
2928 : 10 : asympt_erfc_scaled (result->value.real, x->value.real);
2929 : : else
2930 : 39 : fullprec_erfc_scaled (result->value.real, x->value.real);
2931 : :
2932 : 49 : return range_check (result, "ERFC_SCALED");
2933 : : }
2934 : :
2935 : : #undef MAX_ITER
2936 : : #undef ARG_LIMIT
2937 : :
2938 : :
2939 : : gfc_expr *
2940 : 3629 : gfc_simplify_epsilon (gfc_expr *e)
2941 : : {
2942 : 3629 : gfc_expr *result;
2943 : 3629 : int i;
2944 : :
2945 : 3629 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2946 : :
2947 : 3629 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
2948 : 3629 : mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
2949 : :
2950 : 3629 : return range_check (result, "EPSILON");
2951 : : }
2952 : :
2953 : :
2954 : : gfc_expr *
2955 : 1212 : gfc_simplify_exp (gfc_expr *x)
2956 : : {
2957 : 1212 : gfc_expr *result;
2958 : :
2959 : 1212 : if (x->expr_type != EXPR_CONSTANT)
2960 : : return NULL;
2961 : :
2962 : 145 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2963 : :
2964 : 145 : switch (x->ts.type)
2965 : : {
2966 : 82 : case BT_REAL:
2967 : 82 : mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
2968 : 82 : break;
2969 : :
2970 : 63 : case BT_COMPLEX:
2971 : 63 : gfc_set_model_kind (x->ts.kind);
2972 : 63 : mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
2973 : 63 : break;
2974 : :
2975 : 0 : default:
2976 : 0 : gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2977 : : }
2978 : :
2979 : 145 : return range_check (result, "EXP");
2980 : : }
2981 : :
2982 : :
2983 : : gfc_expr *
2984 : 1020 : gfc_simplify_exponent (gfc_expr *x)
2985 : : {
2986 : 1020 : long int val;
2987 : 1020 : gfc_expr *result;
2988 : :
2989 : 1020 : if (x->expr_type != EXPR_CONSTANT)
2990 : : return NULL;
2991 : :
2992 : 150 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2993 : : &x->where);
2994 : :
2995 : : /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2996 : 150 : if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real))
2997 : : {
2998 : 18 : int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
2999 : 18 : mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
3000 : 18 : return result;
3001 : : }
3002 : :
3003 : : /* EXPONENT(+/- 0.0) = 0 */
3004 : 132 : if (mpfr_zero_p (x->value.real))
3005 : : {
3006 : 12 : mpz_set_ui (result->value.integer, 0);
3007 : 12 : return result;
3008 : : }
3009 : :
3010 : 120 : gfc_set_model (x->value.real);
3011 : :
3012 : 120 : val = (long int) mpfr_get_exp (x->value.real);
3013 : 120 : mpz_set_si (result->value.integer, val);
3014 : :
3015 : 120 : return range_check (result, "EXPONENT");
3016 : : }
3017 : :
3018 : :
3019 : : gfc_expr *
3020 : 60 : gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED,
3021 : : gfc_expr *kind)
3022 : : {
3023 : 60 : if (flag_coarray == GFC_FCOARRAY_NONE)
3024 : : {
3025 : 0 : gfc_current_locus = *gfc_current_intrinsic_where;
3026 : 0 : gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3027 : : return &gfc_bad_expr;
3028 : : }
3029 : :
3030 : 60 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
3031 : : {
3032 : 12 : gfc_expr *result;
3033 : 12 : int actual_kind;
3034 : 12 : if (kind)
3035 : 8 : gfc_extract_int (kind, &actual_kind);
3036 : : else
3037 : 4 : actual_kind = gfc_default_integer_kind;
3038 : :
3039 : 12 : result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus);
3040 : 12 : result->rank = 1;
3041 : 12 : return result;
3042 : : }
3043 : :
3044 : : /* For fcoarray = lib no simplification is possible, because it is not known
3045 : : what images failed or are stopped at compile time. */
3046 : : return NULL;
3047 : : }
3048 : :
3049 : :
3050 : : gfc_expr *
3051 : 0 : gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED)
3052 : : {
3053 : 0 : if (flag_coarray == GFC_FCOARRAY_NONE)
3054 : : {
3055 : 0 : gfc_current_locus = *gfc_current_intrinsic_where;
3056 : 0 : gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3057 : : return &gfc_bad_expr;
3058 : : }
3059 : :
3060 : 0 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
3061 : : {
3062 : 0 : gfc_expr *result;
3063 : 0 : result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
3064 : 0 : result->rank = 0;
3065 : 0 : return result;
3066 : : }
3067 : :
3068 : : /* For fcoarray = lib no simplification is possible, because it is not known
3069 : : what images failed or are stopped at compile time. */
3070 : : return NULL;
3071 : : }
3072 : :
3073 : :
3074 : : gfc_expr *
3075 : 865 : gfc_simplify_float (gfc_expr *a)
3076 : : {
3077 : 865 : gfc_expr *result;
3078 : :
3079 : 865 : if (a->expr_type != EXPR_CONSTANT)
3080 : : return NULL;
3081 : :
3082 : 493 : result = gfc_int2real (a, gfc_default_real_kind);
3083 : :
3084 : 493 : return range_check (result, "FLOAT");
3085 : : }
3086 : :
3087 : :
3088 : : static bool
3089 : 2348 : is_last_ref_vtab (gfc_expr *e)
3090 : : {
3091 : 2348 : gfc_ref *ref;
3092 : 2348 : gfc_component *comp = NULL;
3093 : :
3094 : 2348 : if (e->expr_type != EXPR_VARIABLE)
3095 : : return false;
3096 : :
3097 : 3370 : for (ref = e->ref; ref; ref = ref->next)
3098 : 1040 : if (ref->type == REF_COMPONENT)
3099 : 426 : comp = ref->u.c.component;
3100 : :
3101 : 2330 : if (!e->ref || !comp)
3102 : 1928 : return e->symtree->n.sym->attr.vtab;
3103 : :
3104 : 402 : if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
3105 : 147 : return true;
3106 : :
3107 : : return false;
3108 : : }
3109 : :
3110 : :
3111 : : gfc_expr *
3112 : 542 : gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
3113 : : {
3114 : : /* Avoid simplification of resolved symbols. */
3115 : 542 : if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
3116 : : return NULL;
3117 : :
3118 : 324 : if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
3119 : 27 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3120 : 27 : gfc_type_is_extension_of (mold->ts.u.derived,
3121 : 27 : a->ts.u.derived));
3122 : :
3123 : 297 : if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
3124 : : return NULL;
3125 : :
3126 : 105 : if ((a->ts.type == BT_CLASS && !gfc_expr_attr (a).class_ok)
3127 : 239 : || (mold->ts.type == BT_CLASS && !gfc_expr_attr (mold).class_ok))
3128 : 4 : return NULL;
3129 : :
3130 : : /* Return .false. if the dynamic type can never be an extension. */
3131 : 104 : if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
3132 : 40 : && !gfc_type_is_extension_of
3133 : 40 : (CLASS_DATA (mold)->ts.u.derived,
3134 : 40 : CLASS_DATA (a)->ts.u.derived)
3135 : 5 : && !gfc_type_is_extension_of
3136 : 5 : (CLASS_DATA (a)->ts.u.derived,
3137 : 5 : CLASS_DATA (mold)->ts.u.derived))
3138 : 127 : || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
3139 : 27 : && !gfc_type_is_extension_of
3140 : 27 : (CLASS_DATA (mold)->ts.u.derived,
3141 : : a->ts.u.derived))
3142 : 253 : || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3143 : 64 : && !gfc_type_is_extension_of
3144 : 64 : (mold->ts.u.derived,
3145 : 64 : CLASS_DATA (a)->ts.u.derived)
3146 : 19 : && !gfc_type_is_extension_of
3147 : 19 : (CLASS_DATA (a)->ts.u.derived,
3148 : : mold->ts.u.derived)))
3149 : 13 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3150 : :
3151 : : /* Return .true. if the dynamic type is guaranteed to be an extension. */
3152 : 96 : if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
3153 : 178 : && gfc_type_is_extension_of (mold->ts.u.derived,
3154 : 60 : CLASS_DATA (a)->ts.u.derived))
3155 : 45 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
3156 : :
3157 : : return NULL;
3158 : : }
3159 : :
3160 : :
3161 : : gfc_expr *
3162 : 741 : gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
3163 : : {
3164 : : /* Avoid simplification of resolved symbols. */
3165 : 741 : if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
3166 : : return NULL;
3167 : :
3168 : : /* Return .false. if the dynamic type can never be the
3169 : : same. */
3170 : 639 : if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok)
3171 : 103 : || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok))
3172 : 722 : && !gfc_type_compatible (&a->ts, &b->ts)
3173 : 783 : && !gfc_type_compatible (&b->ts, &a->ts))
3174 : 6 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
3175 : :
3176 : 735 : if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
3177 : : return NULL;
3178 : :
3179 : 18 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
3180 : 18 : gfc_compare_derived_types (a->ts.u.derived,
3181 : 18 : b->ts.u.derived));
3182 : : }
3183 : :
3184 : :
3185 : : gfc_expr *
3186 : 414 : gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
3187 : : {
3188 : 414 : gfc_expr *result;
3189 : 414 : mpfr_t floor;
3190 : 414 : int kind;
3191 : :
3192 : 414 : kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
3193 : 414 : if (kind == -1)
3194 : 0 : gfc_internal_error ("gfc_simplify_floor(): Bad kind");
3195 : :
3196 : 414 : if (e->expr_type != EXPR_CONSTANT)
3197 : : return NULL;
3198 : :
3199 : 28 : mpfr_init2 (floor, mpfr_get_prec (e->value.real));
3200 : 28 : mpfr_floor (floor, e->value.real);
3201 : :
3202 : 28 : result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
3203 : 28 : gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
3204 : :
3205 : 28 : mpfr_clear (floor);
3206 : :
3207 : 28 : return range_check (result, "FLOOR");
3208 : : }
3209 : :
3210 : :
3211 : : gfc_expr *
3212 : 264 : gfc_simplify_fraction (gfc_expr *x)
3213 : : {
3214 : 264 : gfc_expr *result;
3215 : 264 : mpfr_exp_t e;
3216 : :
3217 : 264 : if (x->expr_type != EXPR_CONSTANT)
3218 : : return NULL;
3219 : :
3220 : 84 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
3221 : :
3222 : : /* FRACTION(inf) = NaN. */
3223 : 84 : if (mpfr_inf_p (x->value.real))
3224 : : {
3225 : 12 : mpfr_set_nan (result->value.real);
3226 : 12 : return result;
3227 : : }
3228 : :
3229 : : /* mpfr_frexp() correctly handles zeros and NaNs. */
3230 : 72 : mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE);
3231 : :
3232 : 72 : return range_check (result, "FRACTION");
3233 : : }
3234 : :
3235 : :
3236 : : gfc_expr *
3237 : 204 : gfc_simplify_gamma (gfc_expr *x)
3238 : : {
3239 : 204 : gfc_expr *result;
3240 : :
3241 : 204 : if (x->expr_type != EXPR_CONSTANT)
3242 : : return NULL;
3243 : :
3244 : 54 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3245 : 54 : mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
3246 : :
3247 : 54 : return range_check (result, "GAMMA");
3248 : : }
3249 : :
3250 : :
3251 : : gfc_expr *
3252 : 5575 : gfc_simplify_huge (gfc_expr *e)
3253 : : {
3254 : 5575 : gfc_expr *result;
3255 : 5575 : int i;
3256 : :
3257 : 5575 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3258 : 5575 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3259 : :
3260 : 5575 : switch (e->ts.type)
3261 : : {
3262 : 4279 : case BT_INTEGER:
3263 : 4279 : mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
3264 : 4279 : break;
3265 : :
3266 : 1296 : case BT_REAL:
3267 : 1296 : mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
3268 : 1296 : break;
3269 : :
3270 : 0 : default:
3271 : 0 : gcc_unreachable ();
3272 : : }
3273 : :
3274 : 5575 : return result;
3275 : : }
3276 : :
3277 : :
3278 : : gfc_expr *
3279 : 36 : gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
3280 : : {
3281 : 36 : gfc_expr *result;
3282 : :
3283 : 36 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3284 : : return NULL;
3285 : :
3286 : 12 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3287 : 12 : mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
3288 : 12 : return range_check (result, "HYPOT");
3289 : : }
3290 : :
3291 : :
3292 : : /* We use the processor's collating sequence, because all
3293 : : systems that gfortran currently works on are ASCII. */
3294 : :
3295 : : gfc_expr *
3296 : 9875 : gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
3297 : : {
3298 : 9875 : gfc_expr *result;
3299 : 9875 : gfc_char_t index;
3300 : 9875 : int k;
3301 : :
3302 : 9875 : if (e->expr_type != EXPR_CONSTANT)
3303 : : return NULL;
3304 : :
3305 : 4962 : if (e->value.character.length != 1)
3306 : : {
3307 : 0 : gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
3308 : 0 : return &gfc_bad_expr;
3309 : : }
3310 : :
3311 : 4962 : index = e->value.character.string[0];
3312 : :
3313 : 4962 : if (warn_surprising && index > 127)
3314 : 1 : gfc_warning (OPT_Wsurprising,
3315 : : "Argument of IACHAR function at %L outside of range 0..127",
3316 : : &e->where);
3317 : :
3318 : 4962 : k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
3319 : 4962 : if (k == -1)
3320 : : return &gfc_bad_expr;
3321 : :
3322 : 4962 : result = gfc_get_int_expr (k, &e->where, index);
3323 : :
3324 : 4962 : return range_check (result, "IACHAR");
3325 : : }
3326 : :
3327 : :
3328 : : static gfc_expr *
3329 : 24 : do_bit_and (gfc_expr *result, gfc_expr *e)
3330 : : {
3331 : 24 : gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3332 : 24 : gcc_assert (result->ts.type == BT_INTEGER
3333 : : && result->expr_type == EXPR_CONSTANT);
3334 : :
3335 : 24 : mpz_and (result->value.integer, result->value.integer, e->value.integer);
3336 : 24 : return result;
3337 : : }
3338 : :
3339 : :
3340 : : gfc_expr *
3341 : 163 : gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3342 : : {
3343 : 163 : return simplify_transformation (array, dim, mask, -1, do_bit_and);
3344 : : }
3345 : :
3346 : :
3347 : : static gfc_expr *
3348 : 24 : do_bit_ior (gfc_expr *result, gfc_expr *e)
3349 : : {
3350 : 24 : gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3351 : 24 : gcc_assert (result->ts.type == BT_INTEGER
3352 : : && result->expr_type == EXPR_CONSTANT);
3353 : :
3354 : 24 : mpz_ior (result->value.integer, result->value.integer, e->value.integer);
3355 : 24 : return result;
3356 : : }
3357 : :
3358 : :
3359 : : gfc_expr *
3360 : 115 : gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3361 : : {
3362 : 115 : return simplify_transformation (array, dim, mask, 0, do_bit_ior);
3363 : : }
3364 : :
3365 : :
3366 : : gfc_expr *
3367 : 1835 : gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
3368 : : {
3369 : 1835 : gfc_expr *result;
3370 : :
3371 : 1835 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3372 : : return NULL;
3373 : :
3374 : 263 : result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3375 : 263 : mpz_and (result->value.integer, x->value.integer, y->value.integer);
3376 : :
3377 : 263 : return range_check (result, "IAND");
3378 : : }
3379 : :
3380 : :
3381 : : gfc_expr *
3382 : 394 : gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
3383 : : {
3384 : 394 : gfc_expr *result;
3385 : 394 : int k, pos;
3386 : :
3387 : 394 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3388 : : return NULL;
3389 : :
3390 : 54 : if (!gfc_check_bitfcn (x, y))
3391 : : return &gfc_bad_expr;
3392 : :
3393 : 46 : gfc_extract_int (y, &pos);
3394 : :
3395 : 46 : k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3396 : :
3397 : 46 : result = gfc_copy_expr (x);
3398 : : /* Drop any separate memory representation of x to avoid potential
3399 : : inconsistencies in result. */
3400 : 46 : if (result->representation.string)
3401 : : {
3402 : 12 : free (result->representation.string);
3403 : 12 : result->representation.string = NULL;
3404 : : }
3405 : :
3406 : 46 : convert_mpz_to_unsigned (result->value.integer,
3407 : : gfc_integer_kinds[k].bit_size);
3408 : :
3409 : 46 : mpz_clrbit (result->value.integer, pos);
3410 : :
3411 : 46 : gfc_convert_mpz_to_signed (result->value.integer,
3412 : : gfc_integer_kinds[k].bit_size);
3413 : :
3414 : 46 : return result;
3415 : : }
3416 : :
3417 : :
3418 : : gfc_expr *
3419 : 94 : gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
3420 : : {
3421 : 94 : gfc_expr *result;
3422 : 94 : int pos, len;
3423 : 94 : int i, k, bitsize;
3424 : 94 : int *bits;
3425 : :
3426 : 94 : if (x->expr_type != EXPR_CONSTANT
3427 : 31 : || y->expr_type != EXPR_CONSTANT
3428 : 21 : || z->expr_type != EXPR_CONSTANT)
3429 : : return NULL;
3430 : :
3431 : 16 : if (!gfc_check_ibits (x, y, z))
3432 : : return &gfc_bad_expr;
3433 : :
3434 : 4 : gfc_extract_int (y, &pos);
3435 : 4 : gfc_extract_int (z, &len);
3436 : :
3437 : 4 : k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
3438 : :
3439 : 4 : bitsize = gfc_integer_kinds[k].bit_size;
3440 : :
3441 : 4 : if (pos + len > bitsize)
3442 : : {
3443 : 0 : gfc_error ("Sum of second and third arguments of IBITS exceeds "
3444 : : "bit size at %L", &y->where);
3445 : 0 : return &gfc_bad_expr;
3446 : : }
3447 : :
3448 : 4 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
3449 : 4 : convert_mpz_to_unsigned (result->value.integer,
3450 : : gfc_integer_kinds[k].bit_size);
3451 : :
3452 : 4 : bits = XCNEWVEC (int, bitsize);
3453 : :
3454 : 168 : for (i = 0; i < bitsize; i++)
3455 : 160 : bits[i] = 0;
3456 : :
3457 : 24 : for (i = 0; i < len; i++)
3458 : 20 : bits[i] = mpz_tstbit (x->value.integer, i + pos);
3459 : :
3460 : 164 : for (i = 0; i < bitsize; i++)
3461 : : {
3462 : 160 : if (bits[i] == 0)
3463 : 160 : mpz_clrbit (result->value.integer, i);
3464 : 0 : else if (bits[i] == 1)
3465 : 0 : mpz_setbit (result->value.integer, i);
3466 : : else
3467 : 0 : gfc_internal_error ("IBITS: Bad bit");
3468 : : }
3469 : :
3470 : 4 : free (bits);
3471 : :
3472 : 4 : gfc_convert_mpz_to_signed (result->value.integer,
3473 : : gfc_integer_kinds[k].bit_size);
3474 : :
3475 : 4 : return result;
3476 : : }
3477 : :
3478 : :
3479 : : gfc_expr *
3480 : 334 : gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
3481 : : {
3482 : 334 : gfc_expr *result;
3483 : 334 : int k, pos;
3484 : :
3485 : 334 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3486 : : return NULL;
3487 : :
3488 : 54 : if (!gfc_check_bitfcn (x, y))
3489 : : return &gfc_bad_expr;
3490 : :
3491 : 46 : gfc_extract_int (y, &pos);
3492 : :
3493 : 46 : k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
3494 : :
3495 : 46 : result = gfc_copy_expr (x);
3496 : : /* Drop any separate memory representation of x to avoid potential
3497 : : inconsistencies in result. */
3498 : 46 : if (result->representation.string)
3499 : : {
3500 : 12 : free (result->representation.string);
3501 : 12 : result->representation.string = NULL;
3502 : : }
3503 : :
3504 : 46 : convert_mpz_to_unsigned (result->value.integer,
3505 : : gfc_integer_kinds[k].bit_size);
3506 : :
3507 : 46 : mpz_setbit (result->value.integer, pos);
3508 : :
3509 : 46 : gfc_convert_mpz_to_signed (result->value.integer,
3510 : : gfc_integer_kinds[k].bit_size);
3511 : :
3512 : 46 : return result;
3513 : : }
3514 : :
3515 : :
3516 : : gfc_expr *
3517 : 3552 : gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
3518 : : {
3519 : 3552 : gfc_expr *result;
3520 : 3552 : gfc_char_t index;
3521 : 3552 : int k;
3522 : :
3523 : 3552 : if (e->expr_type != EXPR_CONSTANT)
3524 : : return NULL;
3525 : :
3526 : 1956 : if (e->value.character.length != 1)
3527 : : {
3528 : 2 : gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
3529 : 2 : return &gfc_bad_expr;
3530 : : }
3531 : :
3532 : 1954 : index = e->value.character.string[0];
3533 : :
3534 : 1954 : k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
3535 : 1954 : if (k == -1)
3536 : : return &gfc_bad_expr;
3537 : :
3538 : 1954 : result = gfc_get_int_expr (k, &e->where, index);
3539 : :
3540 : 1954 : return range_check (result, "ICHAR");
3541 : : }
3542 : :
3543 : :
3544 : : gfc_expr *
3545 : 1886 : gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
3546 : : {
3547 : 1886 : gfc_expr *result;
3548 : :
3549 : 1886 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3550 : : return NULL;
3551 : :
3552 : 149 : result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3553 : 149 : mpz_xor (result->value.integer, x->value.integer, y->value.integer);
3554 : :
3555 : 149 : return range_check (result, "IEOR");
3556 : : }
3557 : :
3558 : :
3559 : : gfc_expr *
3560 : 1353 : gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
3561 : : {
3562 : 1353 : gfc_expr *result;
3563 : 1353 : bool back;
3564 : 1353 : HOST_WIDE_INT len, lensub, start, last, i, index = 0;
3565 : 1353 : int k, delta;
3566 : :
3567 : 1353 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
3568 : 362 : || ( b != NULL && b->expr_type != EXPR_CONSTANT))
3569 : : return NULL;
3570 : :
3571 : 206 : back = (b != NULL && b->value.logical != 0);
3572 : :
3573 : 304 : k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
3574 : 304 : if (k == -1)
3575 : : return &gfc_bad_expr;
3576 : :
3577 : 304 : result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
3578 : :
3579 : 304 : len = x->value.character.length;
3580 : 304 : lensub = y->value.character.length;
3581 : :
3582 : 304 : if (len < lensub)
3583 : : {
3584 : 12 : mpz_set_si (result->value.integer, 0);
3585 : 12 : return result;
3586 : : }
3587 : :
3588 : 292 : if (lensub == 0)
3589 : : {
3590 : 24 : if (back)
3591 : 12 : index = len + 1;
3592 : : else
3593 : : index = 1;
3594 : 24 : goto done;
3595 : : }
3596 : :
3597 : 268 : if (!back)
3598 : : {
3599 : 156 : last = len + 1 - lensub;
3600 : 156 : start = 0;
3601 : 156 : delta = 1;
3602 : : }
3603 : : else
3604 : : {
3605 : 112 : last = -1;
3606 : 112 : start = len - lensub;
3607 : 112 : delta = -1;
3608 : : }
3609 : :
3610 : 1335 : for (; start != last; start += delta)
3611 : : {
3612 : 2215 : for (i = 0; i < lensub; i++)
3613 : : {
3614 : 1977 : if (x->value.character.string[start + i]
3615 : 1977 : != y->value.character.string[i])
3616 : : break;
3617 : : }
3618 : 1305 : if (i == lensub)
3619 : : {
3620 : 238 : index = start + 1;
3621 : 238 : goto done;
3622 : : }
3623 : : }
3624 : :
3625 : 30 : done:
3626 : 292 : mpz_set_si (result->value.integer, index);
3627 : 292 : return range_check (result, "INDEX");
3628 : : }
3629 : :
3630 : :
3631 : : static gfc_expr *
3632 : 6231 : simplify_intconv (gfc_expr *e, int kind, const char *name)
3633 : : {
3634 : 6231 : gfc_expr *result = NULL;
3635 : 6231 : int tmp1, tmp2;
3636 : :
3637 : : /* Convert BOZ to integer, and return without range checking. */
3638 : 6231 : if (e->ts.type == BT_BOZ)
3639 : : {
3640 : 1528 : if (!gfc_boz2int (e, kind))
3641 : : return NULL;
3642 : 1528 : result = gfc_copy_expr (e);
3643 : 1528 : return result;
3644 : : }
3645 : :
3646 : 4703 : if (e->expr_type != EXPR_CONSTANT)
3647 : : return NULL;
3648 : :
3649 : : /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
3650 : : warnings. */
3651 : 1034 : tmp1 = warn_conversion;
3652 : 1034 : tmp2 = warn_conversion_extra;
3653 : 1034 : warn_conversion = warn_conversion_extra = 0;
3654 : :
3655 : 1034 : result = gfc_convert_constant (e, BT_INTEGER, kind);
3656 : :
3657 : 1034 : warn_conversion = tmp1;
3658 : 1034 : warn_conversion_extra = tmp2;
3659 : :
3660 : 1034 : if (result == &gfc_bad_expr)
3661 : : return &gfc_bad_expr;
3662 : :
3663 : 1034 : return range_check (result, name);
3664 : : }
3665 : :
3666 : :
3667 : : gfc_expr *
3668 : 6128 : gfc_simplify_int (gfc_expr *e, gfc_expr *k)
3669 : : {
3670 : 6128 : int kind;
3671 : :
3672 : 6128 : kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
3673 : 6128 : if (kind == -1)
3674 : : return &gfc_bad_expr;
3675 : :
3676 : 6128 : return simplify_intconv (e, kind, "INT");
3677 : : }
3678 : :
3679 : : gfc_expr *
3680 : 58 : gfc_simplify_int2 (gfc_expr *e)
3681 : : {
3682 : 58 : return simplify_intconv (e, 2, "INT2");
3683 : : }
3684 : :
3685 : :
3686 : : gfc_expr *
3687 : 45 : gfc_simplify_int8 (gfc_expr *e)
3688 : : {
3689 : 45 : return simplify_intconv (e, 8, "INT8");
3690 : : }
3691 : :
3692 : :
3693 : : gfc_expr *
3694 : 0 : gfc_simplify_long (gfc_expr *e)
3695 : : {
3696 : 0 : return simplify_intconv (e, 4, "LONG");
3697 : : }
3698 : :
3699 : :
3700 : : gfc_expr *
3701 : 1562 : gfc_simplify_ifix (gfc_expr *e)
3702 : : {
3703 : 1562 : gfc_expr *rtrunc, *result;
3704 : :
3705 : 1562 : if (e->expr_type != EXPR_CONSTANT)
3706 : : return NULL;
3707 : :
3708 : 127 : rtrunc = gfc_copy_expr (e);
3709 : 127 : mpfr_trunc (rtrunc->value.real, e->value.real);
3710 : :
3711 : 127 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3712 : : &e->where);
3713 : 127 : gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3714 : :
3715 : 127 : gfc_free_expr (rtrunc);
3716 : :
3717 : 127 : return range_check (result, "IFIX");
3718 : : }
3719 : :
3720 : :
3721 : : gfc_expr *
3722 : 711 : gfc_simplify_idint (gfc_expr *e)
3723 : : {
3724 : 711 : gfc_expr *rtrunc, *result;
3725 : :
3726 : 711 : if (e->expr_type != EXPR_CONSTANT)
3727 : : return NULL;
3728 : :
3729 : 50 : rtrunc = gfc_copy_expr (e);
3730 : 50 : mpfr_trunc (rtrunc->value.real, e->value.real);
3731 : :
3732 : 50 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3733 : : &e->where);
3734 : 50 : gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3735 : :
3736 : 50 : gfc_free_expr (rtrunc);
3737 : :
3738 : 50 : return range_check (result, "IDINT");
3739 : : }
3740 : :
3741 : :
3742 : : gfc_expr *
3743 : 4330 : gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
3744 : : {
3745 : 4330 : gfc_expr *result;
3746 : :
3747 : 4330 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3748 : : return NULL;
3749 : :
3750 : 3049 : result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3751 : 3049 : mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3752 : :
3753 : 3049 : return range_check (result, "IOR");
3754 : : }
3755 : :
3756 : :
3757 : : static gfc_expr *
3758 : 24 : do_bit_xor (gfc_expr *result, gfc_expr *e)
3759 : : {
3760 : 24 : gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3761 : 24 : gcc_assert (result->ts.type == BT_INTEGER
3762 : : && result->expr_type == EXPR_CONSTANT);
3763 : :
3764 : 24 : mpz_xor (result->value.integer, result->value.integer, e->value.integer);
3765 : 24 : return result;
3766 : : }
3767 : :
3768 : :
3769 : : gfc_expr *
3770 : 205 : gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3771 : : {
3772 : 205 : return simplify_transformation (array, dim, mask, 0, do_bit_xor);
3773 : : }
3774 : :
3775 : :
3776 : : gfc_expr *
3777 : 46 : gfc_simplify_is_iostat_end (gfc_expr *x)
3778 : : {
3779 : 46 : if (x->expr_type != EXPR_CONSTANT)
3780 : : return NULL;
3781 : :
3782 : 28 : return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3783 : 28 : mpz_cmp_si (x->value.integer,
3784 : 28 : LIBERROR_END) == 0);
3785 : : }
3786 : :
3787 : :
3788 : : gfc_expr *
3789 : 70 : gfc_simplify_is_iostat_eor (gfc_expr *x)
3790 : : {
3791 : 70 : if (x->expr_type != EXPR_CONSTANT)
3792 : : return NULL;
3793 : :
3794 : 16 : return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3795 : 16 : mpz_cmp_si (x->value.integer,
3796 : 16 : LIBERROR_EOR) == 0);
3797 : : }
3798 : :
3799 : :
3800 : : gfc_expr *
3801 : 1568 : gfc_simplify_isnan (gfc_expr *x)
3802 : : {
3803 : 1568 : if (x->expr_type != EXPR_CONSTANT)
3804 : : return NULL;
3805 : :
3806 : 194 : return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3807 : 194 : mpfr_nan_p (x->value.real));
3808 : : }
3809 : :
3810 : :
3811 : : /* Performs a shift on its first argument. Depending on the last
3812 : : argument, the shift can be arithmetic, i.e. with filling from the
3813 : : left like in the SHIFTA intrinsic. */
3814 : : static gfc_expr *
3815 : 9179 : simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
3816 : : bool arithmetic, int direction)
3817 : : {
3818 : 9179 : gfc_expr *result;
3819 : 9179 : int ashift, *bits, i, k, bitsize, shift;
3820 : :
3821 : 9179 : if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3822 : : return NULL;
3823 : :
3824 : 7632 : gfc_extract_int (s, &shift);
3825 : :
3826 : 7632 : k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
3827 : 7632 : bitsize = gfc_integer_kinds[k].bit_size;
3828 : :
3829 : 7632 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3830 : :
3831 : 7632 : if (shift == 0)
3832 : : {
3833 : 1194 : mpz_set (result->value.integer, e->value.integer);
3834 : 1194 : return result;
3835 : : }
3836 : :
3837 : 6438 : if (direction > 0 && shift < 0)
3838 : : {
3839 : : /* Left shift, as in SHIFTL. */
3840 : 0 : gfc_error ("Second argument of %s is negative at %L", name, &e->where);
3841 : 0 : return &gfc_bad_expr;
3842 : : }
3843 : 6438 : else if (direction < 0)
3844 : : {
3845 : : /* Right shift, as in SHIFTR or SHIFTA. */
3846 : 2778 : if (shift < 0)
3847 : : {
3848 : 0 : gfc_error ("Second argument of %s is negative at %L",
3849 : : name, &e->where);
3850 : 0 : return &gfc_bad_expr;
3851 : : }
3852 : :
3853 : 2778 : shift = -shift;
3854 : : }
3855 : :
3856 : 6438 : ashift = (shift >= 0 ? shift : -shift);
3857 : :
3858 : 6438 : if (ashift > bitsize)
3859 : : {
3860 : 0 : gfc_error ("Magnitude of second argument of %s exceeds bit size "
3861 : : "at %L", name, &e->where);
3862 : 0 : return &gfc_bad_expr;
3863 : : }
3864 : :
3865 : 6438 : bits = XCNEWVEC (int, bitsize);
3866 : :
3867 : 322364 : for (i = 0; i < bitsize; i++)
3868 : 309488 : bits[i] = mpz_tstbit (e->value.integer, i);
3869 : :
3870 : 6438 : if (shift > 0)
3871 : : {
3872 : : /* Left shift. */
3873 : 85723 : for (i = 0; i < shift; i++)
3874 : 82207 : mpz_clrbit (result->value.integer, i);
3875 : :
3876 : 84349 : for (i = 0; i < bitsize - shift; i++)
3877 : : {
3878 : 80833 : if (bits[i] == 0)
3879 : 52189 : mpz_clrbit (result->value.integer, i + shift);
3880 : : else
3881 : 28644 : mpz_setbit (result->value.integer, i + shift);
3882 : : }
3883 : : }
3884 : : else
3885 : : {
3886 : : /* Right shift. */
3887 : 2922 : if (arithmetic && bits[bitsize - 1])
3888 : 456 : for (i = bitsize - 1; i >= bitsize - ashift; i--)
3889 : 414 : mpz_setbit (result->value.integer, i);
3890 : : else
3891 : 75126 : for (i = bitsize - 1; i >= bitsize - ashift; i--)
3892 : 72246 : mpz_clrbit (result->value.integer, i);
3893 : :
3894 : 76710 : for (i = bitsize - 1; i >= ashift; i--)
3895 : : {
3896 : 73788 : if (bits[i] == 0)
3897 : 45390 : mpz_clrbit (result->value.integer, i - ashift);
3898 : : else
3899 : 28398 : mpz_setbit (result->value.integer, i - ashift);
3900 : : }
3901 : : }
3902 : :
3903 : 6438 : gfc_convert_mpz_to_signed (result->value.integer, bitsize);
3904 : 6438 : free (bits);
3905 : :
3906 : 6438 : return result;
3907 : : }
3908 : :
3909 : :
3910 : : gfc_expr *
3911 : 1922 : gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
3912 : : {
3913 : 1922 : return simplify_shift (e, s, "ISHFT", false, 0);
3914 : : }
3915 : :
3916 : :
3917 : : gfc_expr *
3918 : 192 : gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
3919 : : {
3920 : 192 : return simplify_shift (e, s, "LSHIFT", false, 1);
3921 : : }
3922 : :
3923 : :
3924 : : gfc_expr *
3925 : 66 : gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
3926 : : {
3927 : 66 : return simplify_shift (e, s, "RSHIFT", true, -1);
3928 : : }
3929 : :
3930 : :
3931 : : gfc_expr *
3932 : 318 : gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
3933 : : {
3934 : 318 : return simplify_shift (e, s, "SHIFTA", true, -1);
3935 : : }
3936 : :
3937 : :
3938 : : gfc_expr *
3939 : 3501 : gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
3940 : : {
3941 : 3501 : return simplify_shift (e, s, "SHIFTL", false, 1);
3942 : : }
3943 : :
3944 : :
3945 : : gfc_expr *
3946 : 3180 : gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
3947 : : {
3948 : 3180 : return simplify_shift (e, s, "SHIFTR", false, -1);
3949 : : }
3950 : :
3951 : :
3952 : : gfc_expr *
3953 : 1785 : gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
3954 : : {
3955 : 1785 : gfc_expr *result;
3956 : 1785 : int shift, ashift, isize, ssize, delta, k;
3957 : 1785 : int i, *bits;
3958 : :
3959 : 1785 : if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3960 : : return NULL;
3961 : :
3962 : 399 : gfc_extract_int (s, &shift);
3963 : :
3964 : 399 : k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3965 : 399 : isize = gfc_integer_kinds[k].bit_size;
3966 : :
3967 : 399 : if (sz != NULL)
3968 : : {
3969 : 213 : if (sz->expr_type != EXPR_CONSTANT)
3970 : : return NULL;
3971 : :
3972 : 213 : gfc_extract_int (sz, &ssize);
3973 : :
3974 : 213 : if (ssize > isize || ssize <= 0)
3975 : : return &gfc_bad_expr;
3976 : : }
3977 : : else
3978 : 186 : ssize = isize;
3979 : :
3980 : 399 : if (shift >= 0)
3981 : : ashift = shift;
3982 : : else
3983 : : ashift = -shift;
3984 : :
3985 : 399 : if (ashift > ssize)
3986 : : {
3987 : 11 : if (sz == NULL)
3988 : 4 : gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3989 : : "BIT_SIZE of first argument at %C");
3990 : : else
3991 : 7 : gfc_error ("Absolute value of SHIFT shall be less than or equal "
3992 : : "to SIZE at %C");
3993 : 11 : return &gfc_bad_expr;
3994 : : }
3995 : :
3996 : 388 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3997 : :
3998 : 388 : mpz_set (result->value.integer, e->value.integer);
3999 : :
4000 : 388 : if (shift == 0)
4001 : : return result;
4002 : :
4003 : 352 : convert_mpz_to_unsigned (result->value.integer, isize);
4004 : :
4005 : 352 : bits = XCNEWVEC (int, ssize);
4006 : :
4007 : 6469 : for (i = 0; i < ssize; i++)
4008 : 5765 : bits[i] = mpz_tstbit (e->value.integer, i);
4009 : :
4010 : 352 : delta = ssize - ashift;
4011 : :
4012 : 352 : if (shift > 0)
4013 : : {
4014 : 3591 : for (i = 0; i < delta; i++)
4015 : : {
4016 : 3335 : if (bits[i] == 0)
4017 : 2226 : mpz_clrbit (result->value.integer, i + shift);
4018 : : else
4019 : 1109 : mpz_setbit (result->value.integer, i + shift);
4020 : : }
4021 : :
4022 : 1006 : for (i = delta; i < ssize; i++)
4023 : : {
4024 : 750 : if (bits[i] == 0)
4025 : 612 : mpz_clrbit (result->value.integer, i - delta);
4026 : : else
4027 : 138 : mpz_setbit (result->value.integer, i - delta);
4028 : : }
4029 : : }
4030 : : else
4031 : : {
4032 : 288 : for (i = 0; i < ashift; i++)
4033 : : {
4034 : 192 : if (bits[i] == 0)
4035 : 90 : mpz_clrbit (result->value.integer, i + delta);
4036 : : else
4037 : 102 : mpz_setbit (result->value.integer, i + delta);
4038 : : }
4039 : :
4040 : 1584 : for (i = ashift; i < ssize; i++)
4041 : : {
4042 : 1488 : if (bits[i] == 0)
4043 : 624 : mpz_clrbit (result->value.integer, i + shift);
4044 : : else
4045 : 864 : mpz_setbit (result->value.integer, i + shift);
4046 : : }
4047 : : }
4048 : :
4049 : 352 : gfc_convert_mpz_to_signed (result->value.integer, isize);
4050 : :
4051 : 352 : free (bits);
4052 : 352 : return result;
4053 : : }
4054 : :
4055 : :
4056 : : gfc_expr *
4057 : 4473 : gfc_simplify_kind (gfc_expr *e)
4058 : : {
4059 : 4473 : return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
4060 : : }
4061 : :
4062 : :
4063 : : static gfc_expr *
4064 : 13210 : simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
4065 : : gfc_array_spec *as, gfc_ref *ref, bool coarray)
4066 : : {
4067 : 13210 : gfc_expr *l, *u, *result;
4068 : 13210 : int k;
4069 : :
4070 : 22286 : k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4071 : : gfc_default_integer_kind);
4072 : 13210 : if (k == -1)
4073 : : return &gfc_bad_expr;
4074 : :
4075 : 13210 : result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
4076 : :
4077 : : /* For non-variables, LBOUND(expr, DIM=n) = 1 and
4078 : : UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
4079 : 13210 : if (!coarray && array->expr_type != EXPR_VARIABLE)
4080 : : {
4081 : 1414 : if (upper)
4082 : : {
4083 : 782 : gfc_expr* dim = result;
4084 : 782 : mpz_set_si (dim->value.integer, d);
4085 : :
4086 : 782 : result = simplify_size (array, dim, k);
4087 : 782 : gfc_free_expr (dim);
4088 : 782 : if (!result)
4089 : 375 : goto returnNull;
4090 : : }
4091 : : else
4092 : 632 : mpz_set_si (result->value.integer, 1);
4093 : :
4094 : 1039 : goto done;
4095 : : }
4096 : :
4097 : : /* Otherwise, we have a variable expression. */
4098 : 11796 : gcc_assert (array->expr_type == EXPR_VARIABLE);
4099 : 11796 : gcc_assert (as);
4100 : :
4101 : 11796 : if (!gfc_resolve_array_spec (as, 0))
4102 : : return NULL;
4103 : :
4104 : : /* The last dimension of an assumed-size array is special. */
4105 : 11793 : if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
4106 : 1203 : || (coarray && d == as->rank + as->corank
4107 : 440 : && (!upper || flag_coarray == GFC_FCOARRAY_SINGLE)))
4108 : : {
4109 : 592 : if (as->lower[d-1] && as->lower[d-1]->expr_type == EXPR_CONSTANT)
4110 : : {
4111 : 367 : gfc_free_expr (result);
4112 : 367 : return gfc_copy_expr (as->lower[d-1]);
4113 : : }
4114 : :
4115 : 225 : goto returnNull;
4116 : : }
4117 : :
4118 : : /* Then, we need to know the extent of the given dimension. */
4119 : 10394 : if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
4120 : : {
4121 : 10698 : gfc_expr *declared_bound;
4122 : 10698 : int empty_bound;
4123 : 10698 : bool constant_lbound, constant_ubound;
4124 : :
4125 : 10698 : l = as->lower[d-1];
4126 : 10698 : u = as->upper[d-1];
4127 : :
4128 : 10698 : gcc_assert (l != NULL);
4129 : :
4130 : 10698 : constant_lbound = l->expr_type == EXPR_CONSTANT;
4131 : 10698 : constant_ubound = u && u->expr_type == EXPR_CONSTANT;
4132 : :
4133 : 10698 : empty_bound = upper ? 0 : 1;
4134 : 10698 : declared_bound = upper ? u : l;
4135 : :
4136 : 10698 : if ((!upper && !constant_lbound)
4137 : 9779 : || (upper && !constant_ubound))
4138 : 2266 : goto returnNull;
4139 : :
4140 : 8432 : if (!coarray)
4141 : : {
4142 : : /* For {L,U}BOUND, the value depends on whether the array
4143 : : is empty. We can nevertheless simplify if the declared bound
4144 : : has the same value as that of an empty array, in which case
4145 : : the result isn't dependent on the array emptiness. */
4146 : 7865 : if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0)
4147 : 3819 : mpz_set_si (result->value.integer, empty_bound);
4148 : 4046 : else if (!constant_lbound || !constant_ubound)
4149 : : /* Array emptiness can't be determined, we can't simplify. */
4150 : 1815 : goto returnNull;
4151 : 2231 : else if (mpz_cmp (l->value.integer, u->value.integer) > 0)
4152 : 97 : mpz_set_si (result->value.integer, empty_bound);
4153 : : else
4154 : 2134 : mpz_set (result->value.integer, declared_bound->value.integer);
4155 : : }
4156 : : else
4157 : 567 : mpz_set (result->value.integer, declared_bound->value.integer);
4158 : : }
4159 : : else
4160 : : {
4161 : 503 : if (upper)
4162 : : {
4163 : : int d2 = 0, cnt = 0;
4164 : 523 : for (int idx = 0; idx < ref->u.ar.dimen; ++idx)
4165 : : {
4166 : 523 : if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT)
4167 : 120 : d2++;
4168 : 403 : else if (cnt < d - 1)
4169 : 102 : cnt++;
4170 : : else
4171 : : break;
4172 : : }
4173 : 301 : if (!gfc_ref_dimen_size (&ref->u.ar, d2 + d - 1, &result->value.integer, NULL))
4174 : 73 : goto returnNull;
4175 : : }
4176 : : else
4177 : 202 : mpz_set_si (result->value.integer, (long int) 1);
4178 : : }
4179 : :
4180 : 8086 : done:
4181 : 8086 : return range_check (result, upper ? "UBOUND" : "LBOUND");
4182 : :
4183 : 4754 : returnNull:
4184 : 4754 : gfc_free_expr (result);
4185 : 4754 : return NULL;
4186 : : }
4187 : :
4188 : :
4189 : : static gfc_expr *
4190 : 34715 : simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4191 : : {
4192 : 34715 : gfc_ref *ref;
4193 : 34715 : gfc_array_spec *as;
4194 : 34715 : ar_type type = AR_UNKNOWN;
4195 : 34715 : int d;
4196 : :
4197 : 34715 : if (array->ts.type == BT_CLASS)
4198 : : return NULL;
4199 : :
4200 : 33389 : if (array->expr_type != EXPR_VARIABLE)
4201 : : {
4202 : 1242 : as = NULL;
4203 : 1242 : ref = NULL;
4204 : 1242 : goto done;
4205 : : }
4206 : :
4207 : : /* Do not attempt to resolve if error has already been issued. */
4208 : 32147 : if (array->symtree->n.sym->error)
4209 : : return NULL;
4210 : :
4211 : : /* Follow any component references. */
4212 : 32146 : as = array->symtree->n.sym->as;
4213 : 32976 : for (ref = array->ref; ref; ref = ref->next)
4214 : : {
4215 : 32976 : switch (ref->type)
4216 : : {
4217 : 32280 : case REF_ARRAY:
4218 : 32280 : type = ref->u.ar.type;
4219 : 32280 : switch (ref->u.ar.type)
4220 : : {
4221 : 134 : case AR_ELEMENT:
4222 : 134 : as = NULL;
4223 : 134 : continue;
4224 : :
4225 : 31283 : case AR_FULL:
4226 : : /* We're done because 'as' has already been set in the
4227 : : previous iteration. */
4228 : 31283 : goto done;
4229 : :
4230 : : case AR_UNKNOWN:
4231 : : return NULL;
4232 : :
4233 : 863 : case AR_SECTION:
4234 : 863 : as = ref->u.ar.as;
4235 : 863 : goto done;
4236 : : }
4237 : :
4238 : 0 : gcc_unreachable ();
4239 : :
4240 : 696 : case REF_COMPONENT:
4241 : 696 : as = ref->u.c.component->as;
4242 : 696 : continue;
4243 : :
4244 : 0 : case REF_SUBSTRING:
4245 : 0 : case REF_INQUIRY:
4246 : 0 : continue;
4247 : : }
4248 : : }
4249 : :
4250 : 0 : gcc_unreachable ();
4251 : :
4252 : 33388 : done:
4253 : :
4254 : 33388 : if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
4255 : 11596 : || (as->type == AS_ASSUMED_SHAPE && upper)))
4256 : : return NULL;
4257 : :
4258 : : /* 'array' shall not be an unallocated allocatable variable or a pointer that
4259 : : is not associated. */
4260 : 10710 : if (array->expr_type == EXPR_VARIABLE
4261 : 10710 : && (gfc_expr_attr (array).allocatable || gfc_expr_attr (array).pointer))
4262 : 6 : return NULL;
4263 : :
4264 : 10704 : gcc_assert (!as
4265 : : || (as->type != AS_DEFERRED
4266 : : && array->expr_type == EXPR_VARIABLE
4267 : : && !gfc_expr_attr (array).allocatable
4268 : : && !gfc_expr_attr (array).pointer));
4269 : :
4270 : 10704 : if (dim == NULL)
4271 : : {
4272 : : /* Multi-dimensional bounds. */
4273 : 1579 : gfc_expr *bounds[GFC_MAX_DIMENSIONS];
4274 : 1579 : gfc_expr *e;
4275 : 1579 : int k;
4276 : :
4277 : : /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4278 : 1579 : if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE)
4279 : : {
4280 : : /* An error message will be emitted in
4281 : : check_assumed_size_reference (resolve.cc). */
4282 : : return &gfc_bad_expr;
4283 : : }
4284 : :
4285 : : /* Simplify the bounds for each dimension. */
4286 : 4094 : for (d = 0; d < array->rank; d++)
4287 : : {
4288 : 2880 : bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
4289 : : false);
4290 : 2880 : if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
4291 : : {
4292 : : int j;
4293 : :
4294 : 400 : for (j = 0; j < d; j++)
4295 : 36 : gfc_free_expr (bounds[j]);
4296 : :
4297 : 364 : if (gfc_seen_div0)
4298 : : return &gfc_bad_expr;
4299 : : else
4300 : : return bounds[d];
4301 : : }
4302 : : }
4303 : :
4304 : : /* Allocate the result expression. */
4305 : 1897 : k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4306 : : gfc_default_integer_kind);
4307 : 1214 : if (k == -1)
4308 : : return &gfc_bad_expr;
4309 : :
4310 : 1214 : e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
4311 : :
4312 : : /* The result is a rank 1 array; its size is the rank of the first
4313 : : argument to {L,U}BOUND. */
4314 : 1214 : e->rank = 1;
4315 : 1214 : e->shape = gfc_get_shape (1);
4316 : 1214 : mpz_init_set_ui (e->shape[0], array->rank);
4317 : :
4318 : : /* Create the constructor for this array. */
4319 : 4908 : for (d = 0; d < array->rank; d++)
4320 : 2480 : gfc_constructor_append_expr (&e->value.constructor,
4321 : : bounds[d], &e->where);
4322 : :
4323 : : return e;
4324 : : }
4325 : : else
4326 : : {
4327 : : /* A DIM argument is specified. */
4328 : 9125 : if (dim->expr_type != EXPR_CONSTANT)
4329 : : return NULL;
4330 : :
4331 : 9125 : d = mpz_get_si (dim->value.integer);
4332 : :
4333 : 9125 : if ((d < 1 || d > array->rank)
4334 : 9125 : || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
4335 : : {
4336 : 0 : gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4337 : 0 : return &gfc_bad_expr;
4338 : : }
4339 : :
4340 : 8708 : if (as && as->type == AS_ASSUMED_RANK)
4341 : : return NULL;
4342 : :
4343 : 9125 : return simplify_bound_dim (array, kind, d, upper, as, ref, false);
4344 : : }
4345 : : }
4346 : :
4347 : :
4348 : : static gfc_expr *
4349 : 1455 : simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4350 : : {
4351 : 1455 : gfc_ref *ref;
4352 : 1455 : gfc_array_spec *as;
4353 : 1455 : int d;
4354 : :
4355 : 1455 : if (array->expr_type != EXPR_VARIABLE)
4356 : : return NULL;
4357 : :
4358 : : /* Follow any component references. */
4359 : 157 : as = (array->ts.type == BT_CLASS && CLASS_DATA (array))
4360 : 1611 : ? CLASS_DATA (array)->as
4361 : 1299 : : array->symtree->n.sym->as;
4362 : 1671 : for (ref = array->ref; ref; ref = ref->next)
4363 : : {
4364 : 1670 : switch (ref->type)
4365 : : {
4366 : 1454 : case REF_ARRAY:
4367 : 1454 : switch (ref->u.ar.type)
4368 : : {
4369 : 333 : case AR_ELEMENT:
4370 : 333 : if (ref->u.ar.as->corank > 0)
4371 : : {
4372 : 333 : gcc_assert (as == ref->u.ar.as);
4373 : 333 : goto done;
4374 : : }
4375 : 0 : as = NULL;
4376 : 0 : continue;
4377 : :
4378 : 1121 : case AR_FULL:
4379 : : /* We're done because 'as' has already been set in the
4380 : : previous iteration. */
4381 : 1121 : goto done;
4382 : :
4383 : : case AR_UNKNOWN:
4384 : : return NULL;
4385 : :
4386 : 0 : case AR_SECTION:
4387 : 0 : as = ref->u.ar.as;
4388 : 0 : goto done;
4389 : : }
4390 : :
4391 : 0 : gcc_unreachable ();
4392 : :
4393 : 216 : case REF_COMPONENT:
4394 : 216 : as = ref->u.c.component->as;
4395 : 216 : continue;
4396 : :
4397 : 0 : case REF_SUBSTRING:
4398 : 0 : case REF_INQUIRY:
4399 : 0 : continue;
4400 : : }
4401 : : }
4402 : :
4403 : 1 : if (!as)
4404 : 0 : gcc_unreachable ();
4405 : :
4406 : 1 : done:
4407 : :
4408 : 1455 : if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
4409 : : return NULL;
4410 : :
4411 : 755 : if (dim == NULL)
4412 : : {
4413 : : /* Multi-dimensional cobounds. */
4414 : : gfc_expr *bounds[GFC_MAX_DIMENSIONS];
4415 : : gfc_expr *e;
4416 : : int k;
4417 : :
4418 : : /* Simplify the cobounds for each dimension. */
4419 : 703 : for (d = 0; d < as->corank; d++)
4420 : : {
4421 : 608 : bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
4422 : : upper, as, ref, true);
4423 : 608 : if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
4424 : : {
4425 : : int j;
4426 : :
4427 : 270 : for (j = 0; j < d; j++)
4428 : 120 : gfc_free_expr (bounds[j]);
4429 : : return bounds[d];
4430 : : }
4431 : : }
4432 : :
4433 : : /* Allocate the result expression. */
4434 : 95 : e = gfc_get_expr ();
4435 : 95 : e->where = array->where;
4436 : 95 : e->expr_type = EXPR_ARRAY;
4437 : 95 : e->ts.type = BT_INTEGER;
4438 : 167 : k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
4439 : : gfc_default_integer_kind);
4440 : 95 : if (k == -1)
4441 : : {
4442 : 0 : gfc_free_expr (e);
4443 : 0 : return &gfc_bad_expr;
4444 : : }
4445 : 95 : e->ts.kind = k;
4446 : :
4447 : : /* The result is a rank 1 array; its size is the rank of the first
4448 : : argument to {L,U}COBOUND. */
4449 : 95 : e->rank = 1;
4450 : 95 : e->shape = gfc_get_shape (1);
4451 : 95 : mpz_init_set_ui (e->shape[0], as->corank);
4452 : :
4453 : : /* Create the constructor for this array. */
4454 : 528 : for (d = 0; d < as->corank; d++)
4455 : 338 : gfc_constructor_append_expr (&e->value.constructor,
4456 : : bounds[d], &e->where);
4457 : : return e;
4458 : : }
4459 : : else
4460 : : {
4461 : : /* A DIM argument is specified. */
4462 : 510 : if (dim->expr_type != EXPR_CONSTANT)
4463 : : return NULL;
4464 : :
4465 : 370 : d = mpz_get_si (dim->value.integer);
4466 : :
4467 : 370 : if (d < 1 || d > as->corank)
4468 : : {
4469 : 0 : gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4470 : 0 : return &gfc_bad_expr;
4471 : : }
4472 : :
4473 : 370 : return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
4474 : : }
4475 : : }
4476 : :
4477 : :
4478 : : gfc_expr *
4479 : 20061 : gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4480 : : {
4481 : 20061 : return simplify_bound (array, dim, kind, 0);
4482 : : }
4483 : :
4484 : :
4485 : : gfc_expr *
4486 : 509 : gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4487 : : {
4488 : 509 : return simplify_cobound (array, dim, kind, 0);
4489 : : }
4490 : :
4491 : : gfc_expr *
4492 : 1068 : gfc_simplify_leadz (gfc_expr *e)
4493 : : {
4494 : 1068 : unsigned long lz, bs;
4495 : 1068 : int i;
4496 : :
4497 : 1068 : if (e->expr_type != EXPR_CONSTANT)
4498 : : return NULL;
4499 : :
4500 : 258 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4501 : 258 : bs = gfc_integer_kinds[i].bit_size;
4502 : 258 : if (mpz_cmp_si (e->value.integer, 0) == 0)
4503 : : lz = bs;
4504 : 222 : else if (mpz_cmp_si (e->value.integer, 0) < 0)
4505 : : lz = 0;
4506 : : else
4507 : 132 : lz = bs - mpz_sizeinbase (e->value.integer, 2);
4508 : :
4509 : 258 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
4510 : : }
4511 : :
4512 : :
4513 : : /* Check for constant length of a substring. */
4514 : :
4515 : : static bool
4516 : 16129 : substring_has_constant_len (gfc_expr *e)
4517 : : {
4518 : 16129 : gfc_ref *ref;
4519 : 16129 : HOST_WIDE_INT istart, iend, length;
4520 : 16129 : bool equal_length = false;
4521 : :
4522 : 16129 : if (e->ts.type != BT_CHARACTER)
4523 : : return false;
4524 : :
4525 : 22920 : for (ref = e->ref; ref; ref = ref->next)
4526 : 7310 : if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY)
4527 : : break;
4528 : :
4529 : 16129 : if (!ref
4530 : 519 : || ref->type != REF_SUBSTRING
4531 : 519 : || !ref->u.ss.start
4532 : 519 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
4533 : 206 : || !ref->u.ss.end
4534 : 206 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
4535 : : return false;
4536 : :
4537 : : /* Basic checks on substring starting and ending indices. */
4538 : 206 : if (!gfc_resolve_substring (ref, &equal_length))
4539 : : return false;
4540 : :
4541 : 206 : istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer);
4542 : 206 : iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer);
4543 : :
4544 : 206 : if (istart <= iend)
4545 : 198 : length = iend - istart + 1;
4546 : : else
4547 : : length = 0;
4548 : :
4549 : : /* Fix substring length. */
4550 : 206 : e->value.character.length = length;
4551 : :
4552 : 206 : return true;
4553 : : }
4554 : :
4555 : :
4556 : : gfc_expr *
4557 : 16651 : gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
4558 : : {
4559 : 16651 : gfc_expr *result;
4560 : 16651 : int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
4561 : :
4562 : 16651 : if (k == -1)
4563 : : return &gfc_bad_expr;
4564 : :
4565 : 16651 : if (e->expr_type == EXPR_CONSTANT
4566 : 16651 : || substring_has_constant_len (e))
4567 : : {
4568 : 728 : result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4569 : 728 : mpz_set_si (result->value.integer, e->value.character.length);
4570 : 728 : return range_check (result, "LEN");
4571 : : }
4572 : 15923 : else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
4573 : 5335 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
4574 : 2804 : && e->ts.u.cl->length->ts.type == BT_INTEGER)
4575 : : {
4576 : 2804 : result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4577 : 2804 : mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
4578 : 2804 : return range_check (result, "LEN");
4579 : : }
4580 : 13119 : else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
4581 : 11387 : && e->symtree->n.sym)
4582 : : {
4583 : 11387 : if (e->symtree->n.sym->ts.type != BT_DERIVED
4584 : 10993 : && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
4585 : 865 : && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
4586 : 367 : && e->symtree->n.sym->assoc->target->symtree->n.sym
4587 : 367 : && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
4588 : : /* The expression in assoc->target points to a ref to the _data
4589 : : component of the unlimited polymorphic entity. To get the _len
4590 : : component the last _data ref needs to be stripped and a ref to the
4591 : : _len component added. */
4592 : 367 : return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
4593 : 11020 : else if (e->symtree->n.sym->ts.type == BT_DERIVED
4594 : 394 : && e->ref && e->ref->type == REF_COMPONENT
4595 : 394 : && e->ref->u.c.component->attr.pdt_string
4596 : 36 : && e->ref->u.c.component->ts.type == BT_CHARACTER
4597 : 36 : && e->ref->u.c.component->ts.u.cl->length)
4598 : : {
4599 : 36 : if (gfc_init_expr_flag)
4600 : : {
4601 : 6 : gfc_expr* tmp;
4602 : 12 : tmp = gfc_pdt_find_component_copy_initializer (e->symtree->n.sym,
4603 : : e->ref->u.c
4604 : : .component->ts.u.cl
4605 : 6 : ->length->symtree
4606 : : ->name);
4607 : 6 : if (tmp)
4608 : : return tmp;
4609 : : }
4610 : : else
4611 : : {
4612 : 30 : gfc_expr *len_expr = gfc_copy_expr (e);
4613 : 30 : gfc_free_ref_list (len_expr->ref);
4614 : 30 : len_expr->ref = NULL;
4615 : 30 : gfc_find_component (len_expr->symtree->n.sym->ts.u.derived, e->ref
4616 : 30 : ->u.c.component->ts.u.cl->length->symtree
4617 : : ->name,
4618 : : false, true, &len_expr->ref);
4619 : 30 : len_expr->ts = len_expr->ref->u.c.component->ts;
4620 : 30 : return len_expr;
4621 : : }
4622 : : }
4623 : : }
4624 : : return NULL;
4625 : : }
4626 : :
4627 : :
4628 : : gfc_expr *
4629 : 4050 : gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
4630 : : {
4631 : 4050 : gfc_expr *result;
4632 : 4050 : size_t count, len, i;
4633 : 4050 : int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
4634 : :
4635 : 4050 : if (k == -1)
4636 : : return &gfc_bad_expr;
4637 : :
4638 : : /* If the expression is either an array element or section, an array
4639 : : parameter must be built so that the reference can be applied. Constant
4640 : : references should have already been simplified away. All other cases
4641 : : can proceed to translation, where kind conversion will occur silently. */
4642 : 4050 : if (e->expr_type == EXPR_VARIABLE
4643 : 3188 : && e->ts.type == BT_CHARACTER
4644 : 3188 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER
4645 : 129 : && e->ref && e->ref->type == REF_ARRAY
4646 : 129 : && e->ref->u.ar.type != AR_FULL
4647 : 82 : && e->symtree->n.sym->value)
4648 : : {
4649 : 82 : char name[2*GFC_MAX_SYMBOL_LEN + 12];
4650 : 82 : gfc_namespace *ns = e->symtree->n.sym->ns;
4651 : 82 : gfc_symtree *st;
4652 : 82 : gfc_expr *expr;
4653 : 82 : gfc_expr *p;
4654 : 82 : gfc_constructor *c;
4655 : 82 : int cnt = 0;
4656 : :
4657 : 82 : sprintf (name, "_len_trim_%s_%s", e->symtree->n.sym->name,
4658 : 82 : ns->proc_name->name);
4659 : 82 : st = gfc_find_symtree (ns->sym_root, name);
4660 : 82 : if (st)
4661 : 44 : goto already_built;
4662 : :
4663 : : /* Recursively call this fcn to simplify the constructor elements. */
4664 : 38 : expr = gfc_copy_expr (e->symtree->n.sym->value);
4665 : 38 : expr->ts.type = BT_INTEGER;
4666 : 38 : expr->ts.kind = k;
4667 : 38 : expr->ts.u.cl = NULL;
4668 : 38 : c = gfc_constructor_first (expr->value.constructor);
4669 : 237 : for (; c; c = gfc_constructor_next (c))
4670 : : {
4671 : 161 : if (c->iterator)
4672 : 0 : continue;
4673 : :
4674 : 161 : if (c->expr && c->expr->ts.type == BT_CHARACTER)
4675 : : {
4676 : 161 : p = gfc_simplify_len_trim (c->expr, kind);
4677 : 161 : if (p == NULL)
4678 : 0 : goto clean_up;
4679 : 161 : gfc_replace_expr (c->expr, p);
4680 : 161 : cnt++;
4681 : : }
4682 : : }
4683 : :
4684 : 38 : if (cnt)
4685 : : {
4686 : : /* Build a new parameter to take the result. */
4687 : 38 : st = gfc_new_symtree (&ns->sym_root, name);
4688 : 38 : st->n.sym = gfc_new_symbol (st->name, ns);
4689 : 38 : st->n.sym->value = expr;
4690 : 38 : st->n.sym->ts = expr->ts;
4691 : 38 : st->n.sym->attr.dimension = 1;
4692 : 38 : st->n.sym->attr.save = SAVE_IMPLICIT;
4693 : 38 : st->n.sym->attr.flavor = FL_PARAMETER;
4694 : 38 : st->n.sym->as = gfc_copy_array_spec (e->symtree->n.sym->as);
4695 : 38 : gfc_set_sym_referenced (st->n.sym);
4696 : 38 : st->n.sym->refs++;
4697 : 38 : gfc_commit_symbol (st->n.sym);
4698 : :
4699 : 82 : already_built:
4700 : : /* Build a return expression. */
4701 : 82 : expr = gfc_copy_expr (e);
4702 : 82 : expr->ts = st->n.sym->ts;
4703 : 82 : expr->symtree = st;
4704 : 82 : gfc_expression_rank (expr);
4705 : 82 : return expr;
4706 : : }
4707 : :
4708 : 0 : clean_up:
4709 : 0 : gfc_free_expr (expr);
4710 : 0 : return NULL;
4711 : : }
4712 : :
4713 : 3968 : if (e->expr_type != EXPR_CONSTANT)
4714 : : return NULL;
4715 : :
4716 : 393 : len = e->value.character.length;
4717 : 1220 : for (count = 0, i = 1; i <= len; i++)
4718 : 1208 : if (e->value.character.string[len - i] == ' ')
4719 : 827 : count++;
4720 : : else
4721 : : break;
4722 : :
4723 : 393 : result = gfc_get_int_expr (k, &e->where, len - count);
4724 : 393 : return range_check (result, "LEN_TRIM");
4725 : : }
4726 : :
4727 : : gfc_expr *
4728 : 50 : gfc_simplify_lgamma (gfc_expr *x)
4729 : : {
4730 : 50 : gfc_expr *result;
4731 : 50 : int sg;
4732 : :
4733 : 50 : if (x->expr_type != EXPR_CONSTANT)
4734 : : return NULL;
4735 : :
4736 : 42 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4737 : 42 : mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
4738 : :
4739 : 42 : return range_check (result, "LGAMMA");
4740 : : }
4741 : :
4742 : :
4743 : : gfc_expr *
4744 : 70 : gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
4745 : : {
4746 : 70 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4747 : : return NULL;
4748 : :
4749 : 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4750 : 2 : gfc_compare_string (a, b) >= 0);
4751 : : }
4752 : :
4753 : :
4754 : : gfc_expr *
4755 : 91 : gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
4756 : : {
4757 : 91 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4758 : : return NULL;
4759 : :
4760 : 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4761 : 2 : gfc_compare_string (a, b) > 0);
4762 : : }
4763 : :
4764 : :
4765 : : gfc_expr *
4766 : 79 : gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
4767 : : {
4768 : 79 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4769 : : return NULL;
4770 : :
4771 : 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4772 : 2 : gfc_compare_string (a, b) <= 0);
4773 : : }
4774 : :
4775 : :
4776 : : gfc_expr *
4777 : 82 : gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
4778 : : {
4779 : 82 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4780 : : return NULL;
4781 : :
4782 : 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4783 : 2 : gfc_compare_string (a, b) < 0);
4784 : : }
4785 : :
4786 : :
4787 : : gfc_expr *
4788 : 544 : gfc_simplify_log (gfc_expr *x)
4789 : : {
4790 : 544 : gfc_expr *result;
4791 : :
4792 : 544 : if (x->expr_type != EXPR_CONSTANT)
4793 : : return NULL;
4794 : :
4795 : 239 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4796 : :
4797 : 239 : switch (x->ts.type)
4798 : : {
4799 : 116 : case BT_REAL:
4800 : 116 : if (mpfr_sgn (x->value.real) <= 0)
4801 : : {
4802 : 0 : gfc_error ("Argument of LOG at %L cannot be less than or equal "
4803 : : "to zero", &x->where);
4804 : 0 : gfc_free_expr (result);
4805 : 0 : return &gfc_bad_expr;
4806 : : }
4807 : :
4808 : 116 : mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
4809 : 116 : break;
4810 : :
4811 : 123 : case BT_COMPLEX:
4812 : 123 : if (mpfr_zero_p (mpc_realref (x->value.complex))
4813 : 0 : && mpfr_zero_p (mpc_imagref (x->value.complex)))
4814 : : {
4815 : 0 : gfc_error ("Complex argument of LOG at %L cannot be zero",
4816 : : &x->where);
4817 : 0 : gfc_free_expr (result);
4818 : 0 : return &gfc_bad_expr;
4819 : : }
4820 : :
4821 : 123 : gfc_set_model_kind (x->ts.kind);
4822 : 123 : mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4823 : 123 : break;
4824 : :
4825 : 0 : default:
4826 : 0 : gfc_internal_error ("gfc_simplify_log: bad type");
4827 : : }
4828 : :
4829 : 239 : return range_check (result, "LOG");
4830 : : }
4831 : :
4832 : :
4833 : : gfc_expr *
4834 : 408 : gfc_simplify_log10 (gfc_expr *x)
4835 : : {
4836 : 408 : gfc_expr *result;
4837 : :
4838 : 408 : if (x->expr_type != EXPR_CONSTANT)
4839 : : return NULL;
4840 : :
4841 : 97 : if (mpfr_sgn (x->value.real) <= 0)
4842 : : {
4843 : 0 : gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4844 : : "to zero", &x->where);
4845 : 0 : return &gfc_bad_expr;
4846 : : }
4847 : :
4848 : 97 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4849 : 97 : mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
4850 : :
4851 : 97 : return range_check (result, "LOG10");
4852 : : }
4853 : :
4854 : :
4855 : : gfc_expr *
4856 : 52 : gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
4857 : : {
4858 : 52 : int kind;
4859 : :
4860 : 52 : kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
4861 : 52 : if (kind < 0)
4862 : : return &gfc_bad_expr;
4863 : :
4864 : 52 : if (e->expr_type != EXPR_CONSTANT)
4865 : : return NULL;
4866 : :
4867 : 4 : return gfc_get_logical_expr (kind, &e->where, e->value.logical);
4868 : : }
4869 : :
4870 : :
4871 : : gfc_expr*
4872 : 1197 : gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
4873 : : {
4874 : 1197 : gfc_expr *result;
4875 : 1197 : int row, result_rows, col, result_columns;
4876 : 1197 : int stride_a, offset_a, stride_b, offset_b;
4877 : :
4878 : 1197 : if (!is_constant_array_expr (matrix_a)
4879 : 1197 : || !is_constant_array_expr (matrix_b))
4880 : 1146 : return NULL;
4881 : :
4882 : : /* MATMUL should do mixed-mode arithmetic. Set the result type. */
4883 : 51 : if (matrix_a->ts.type != matrix_b->ts.type)
4884 : : {
4885 : 12 : gfc_expr e;
4886 : 12 : e.expr_type = EXPR_OP;
4887 : 12 : gfc_clear_ts (&e.ts);
4888 : 12 : e.value.op.op = INTRINSIC_NONE;
4889 : 12 : e.value.op.op1 = matrix_a;
4890 : 12 : e.value.op.op2 = matrix_b;
4891 : 12 : gfc_type_convert_binary (&e, 1);
4892 : 12 : result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where);
4893 : : }
4894 : : else
4895 : : {
4896 : 39 : result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind,
4897 : : &matrix_a->where);
4898 : : }
4899 : :
4900 : 51 : if (matrix_a->rank == 1 && matrix_b->rank == 2)
4901 : : {
4902 : 7 : result_rows = 1;
4903 : 7 : result_columns = mpz_get_si (matrix_b->shape[1]);
4904 : 7 : stride_a = 1;
4905 : 7 : stride_b = mpz_get_si (matrix_b->shape[0]);
4906 : :
4907 : 7 : result->rank = 1;
4908 : 7 : result->shape = gfc_get_shape (result->rank);
4909 : 7 : mpz_init_set_si (result->shape[0], result_columns);
4910 : : }
4911 : 44 : else if (matrix_a->rank == 2 && matrix_b->rank == 1)
4912 : : {
4913 : 6 : result_rows = mpz_get_si (matrix_a->shape[0]);
4914 : 6 : result_columns = 1;
4915 : 6 : stride_a = mpz_get_si (matrix_a->shape[0]);
4916 : 6 : stride_b = 1;
4917 : :
4918 : 6 : result->rank = 1;
4919 : 6 : result->shape = gfc_get_shape (result->rank);
4920 : 6 : mpz_init_set_si (result->shape[0], result_rows);
4921 : : }
4922 : 38 : else if (matrix_a->rank == 2 && matrix_b->rank == 2)
4923 : : {
4924 : 38 : result_rows = mpz_get_si (matrix_a->shape[0]);
4925 : 38 : result_columns = mpz_get_si (matrix_b->shape[1]);
4926 : 38 : stride_a = mpz_get_si (matrix_a->shape[0]);
4927 : 38 : stride_b = mpz_get_si (matrix_b->shape[0]);
4928 : :
4929 : 38 : result->rank = 2;
4930 : 38 : result->shape = gfc_get_shape (result->rank);
4931 : 38 : mpz_init_set_si (result->shape[0], result_rows);
4932 : 38 : mpz_init_set_si (result->shape[1], result_columns);
4933 : : }
4934 : : else
4935 : 0 : gcc_unreachable();
4936 : :
4937 : 51 : offset_b = 0;
4938 : 175 : for (col = 0; col < result_columns; ++col)
4939 : : {
4940 : : offset_a = 0;
4941 : :
4942 : 434 : for (row = 0; row < result_rows; ++row)
4943 : : {
4944 : 310 : gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
4945 : : matrix_b, 1, offset_b, false);
4946 : 310 : gfc_constructor_append_expr (&result->value.constructor,
4947 : : e, NULL);
4948 : :
4949 : 310 : offset_a += 1;
4950 : : }
4951 : :
4952 : 124 : offset_b += stride_b;
4953 : : }
4954 : :
4955 : : return result;
4956 : : }
4957 : :
4958 : :
4959 : : gfc_expr *
4960 : 285 : gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
4961 : : {
4962 : 285 : gfc_expr *result;
4963 : 285 : int kind, arg, k;
4964 : :
4965 : 285 : if (i->expr_type != EXPR_CONSTANT)
4966 : : return NULL;
4967 : :
4968 : 213 : kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
4969 : 213 : if (kind == -1)
4970 : : return &gfc_bad_expr;
4971 : 213 : k = gfc_validate_kind (BT_INTEGER, kind, false);
4972 : :
4973 : 213 : bool fail = gfc_extract_int (i, &arg);
4974 : 213 : gcc_assert (!fail);
4975 : :
4976 : 213 : if (!gfc_check_mask (i, kind_arg))
4977 : : return &gfc_bad_expr;
4978 : :
4979 : 211 : result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4980 : :
4981 : : /* MASKR(n) = 2^n - 1 */
4982 : 211 : mpz_set_ui (result->value.integer, 1);
4983 : 211 : mpz_mul_2exp (result->value.integer, result->value.integer, arg);
4984 : 211 : mpz_sub_ui (result->value.integer, result->value.integer, 1);
4985 : :
4986 : 211 : gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4987 : :
4988 : 211 : return result;
4989 : : }
4990 : :
4991 : :
4992 : : gfc_expr *
4993 : 297 : gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
4994 : : {
4995 : 297 : gfc_expr *result;
4996 : 297 : int kind, arg, k;
4997 : 297 : mpz_t z;
4998 : :
4999 : 297 : if (i->expr_type != EXPR_CONSTANT)
5000 : : return NULL;
5001 : :
5002 : 217 : kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
5003 : 217 : if (kind == -1)
5004 : : return &gfc_bad_expr;
5005 : 217 : k = gfc_validate_kind (BT_INTEGER, kind, false);
5006 : :
5007 : 217 : bool fail = gfc_extract_int (i, &arg);
5008 : 217 : gcc_assert (!fail);
5009 : :
5010 : 217 : if (!gfc_check_mask (i, kind_arg))
5011 : : return &gfc_bad_expr;
5012 : :
5013 : 213 : result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
5014 : :
5015 : : /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
5016 : 213 : mpz_init_set_ui (z, 1);
5017 : 213 : mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
5018 : 213 : mpz_set_ui (result->value.integer, 1);
5019 : 213 : mpz_mul_2exp (result->value.integer, result->value.integer,
5020 : 213 : gfc_integer_kinds[k].bit_size - arg);
5021 : 213 : mpz_sub (result->value.integer, z, result->value.integer);
5022 : 213 : mpz_clear (z);
5023 : :
5024 : 213 : gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
5025 : :
5026 : 213 : return result;
5027 : : }
5028 : :
5029 : :
5030 : : gfc_expr *
5031 : 4071 : gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
5032 : : {
5033 : 4071 : gfc_expr * result;
5034 : 4071 : gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
5035 : :
5036 : 4071 : if (mask->expr_type == EXPR_CONSTANT)
5037 : : {
5038 : : /* The standard requires evaluation of all function arguments.
5039 : : Simplify only when the other dropped argument (FSOURCE or TSOURCE)
5040 : : is a constant expression. */
5041 : 699 : if (mask->value.logical)
5042 : : {
5043 : 482 : if (!gfc_is_constant_expr (fsource))
5044 : : return NULL;
5045 : 168 : result = gfc_copy_expr (tsource);
5046 : : }
5047 : : else
5048 : : {
5049 : 217 : if (!gfc_is_constant_expr (tsource))
5050 : : return NULL;
5051 : 67 : result = gfc_copy_expr (fsource);
5052 : : }
5053 : :
5054 : : /* Parenthesis is needed to get lower bounds of 1. */
5055 : 235 : result = gfc_get_parentheses (result);
5056 : 235 : gfc_simplify_expr (result, 1);
5057 : 235 : return result;
5058 : : }
5059 : :
5060 : 769 : if (!mask->rank || !is_constant_array_expr (mask)
5061 : 3419 : || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
5062 : 3353 : return NULL;
5063 : :
5064 : 19 : result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
5065 : : &tsource->where);
5066 : 19 : if (tsource->ts.type == BT_DERIVED)
5067 : 1 : result->ts.u.derived = tsource->ts.u.derived;
5068 : 18 : else if (tsource->ts.type == BT_CHARACTER)
5069 : 6 : result->ts.u.cl = tsource->ts.u.cl;
5070 : :
5071 : 19 : tsource_ctor = gfc_constructor_first (tsource->value.constructor);
5072 : 19 : fsource_ctor = gfc_constructor_first (fsource->value.constructor);
5073 : 19 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5074 : :
5075 : 87 : while (mask_ctor)
5076 : : {
5077 : 49 : if (mask_ctor->expr->value.logical)
5078 : 31 : gfc_constructor_append_expr (&result->value.constructor,
5079 : : gfc_copy_expr (tsource_ctor->expr),
5080 : : NULL);
5081 : : else
5082 : 18 : gfc_constructor_append_expr (&result->value.constructor,
5083 : : gfc_copy_expr (fsource_ctor->expr),
5084 : : NULL);
5085 : 49 : tsource_ctor = gfc_constructor_next (tsource_ctor);
5086 : 49 : fsource_ctor = gfc_constructor_next (fsource_ctor);
5087 : 49 : mask_ctor = gfc_constructor_next (mask_ctor);
5088 : : }
5089 : :
5090 : 19 : result->shape = gfc_get_shape (1);
5091 : 19 : gfc_array_size (result, &result->shape[0]);
5092 : :
5093 : 19 : return result;
5094 : : }
5095 : :
5096 : :
5097 : : gfc_expr *
5098 : 342 : gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
5099 : : {
5100 : 342 : mpz_t arg1, arg2, mask;
5101 : 342 : gfc_expr *result;
5102 : :
5103 : 342 : if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
5104 : 282 : || mask_expr->expr_type != EXPR_CONSTANT)
5105 : : return NULL;
5106 : :
5107 : 282 : result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
5108 : :
5109 : : /* Convert all argument to unsigned. */
5110 : 282 : mpz_init_set (arg1, i->value.integer);
5111 : 282 : mpz_init_set (arg2, j->value.integer);
5112 : 282 : mpz_init_set (mask, mask_expr->value.integer);
5113 : :
5114 : : /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
5115 : 282 : mpz_and (arg1, arg1, mask);
5116 : 282 : mpz_com (mask, mask);
5117 : 282 : mpz_and (arg2, arg2, mask);
5118 : 282 : mpz_ior (result->value.integer, arg1, arg2);
5119 : :
5120 : 282 : mpz_clear (arg1);
5121 : 282 : mpz_clear (arg2);
5122 : 282 : mpz_clear (mask);
5123 : :
5124 : 282 : return result;
5125 : : }
5126 : :
5127 : :
5128 : : /* Selects between current value and extremum for simplify_min_max
5129 : : and simplify_minval_maxval. */
5130 : : static int
5131 : 2690 : min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
5132 : : {
5133 : 2690 : int ret;
5134 : :
5135 : 2690 : switch (arg->ts.type)
5136 : : {
5137 : 1585 : case BT_INTEGER:
5138 : 1585 : if (extremum->ts.kind < arg->ts.kind)
5139 : 6 : extremum->ts.kind = arg->ts.kind;
5140 : 1585 : ret = mpz_cmp (arg->value.integer,
5141 : 1585 : extremum->value.integer) * sign;
5142 : 1585 : if (ret > 0)
5143 : 1047 : mpz_set (extremum->value.integer, arg->value.integer);
5144 : : break;
5145 : :
5146 : 608 : case BT_REAL:
5147 : 608 : if (extremum->ts.kind < arg->ts.kind)
5148 : 30 : extremum->ts.kind = arg->ts.kind;
5149 : 608 : if (mpfr_nan_p (extremum->value.real))
5150 : : {
5151 : 192 : ret = 1;
5152 : 192 : mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
5153 : : }
5154 : 416 : else if (mpfr_nan_p (arg->value.real))
5155 : : ret = -1;
5156 : : else
5157 : : {
5158 : 296 : ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign;
5159 : 296 : if (ret > 0)
5160 : 145 : mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
5161 : : }
5162 : : break;
5163 : :
5164 : 497 : case BT_CHARACTER:
5165 : : #define LENGTH(x) ((x)->value.character.length)
5166 : : #define STRING(x) ((x)->value.character.string)
5167 : 497 : if (LENGTH (extremum) < LENGTH(arg))
5168 : : {
5169 : 12 : gfc_char_t *tmp = STRING(extremum);
5170 : :
5171 : 12 : STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
5172 : 12 : memcpy (STRING(extremum), tmp,
5173 : 12 : LENGTH(extremum) * sizeof (gfc_char_t));
5174 : 12 : gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
5175 : 12 : LENGTH(arg) - LENGTH(extremum));
5176 : 12 : STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
5177 : 12 : LENGTH(extremum) = LENGTH(arg);
5178 : 12 : free (tmp);
5179 : : }
5180 : 497 : ret = gfc_compare_string (arg, extremum) * sign;
5181 : 497 : if (ret > 0)
5182 : : {
5183 : 187 : free (STRING(extremum));
5184 : 187 : STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
5185 : 187 : memcpy (STRING(extremum), STRING(arg),
5186 : 187 : LENGTH(arg) * sizeof (gfc_char_t));
5187 : 187 : gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
5188 : 187 : LENGTH(extremum) - LENGTH(arg));
5189 : 187 : STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
5190 : : }
5191 : : #undef LENGTH
5192 : : #undef STRING
5193 : : break;
5194 : :
5195 : 0 : default:
5196 : 0 : gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5197 : : }
5198 : 2690 : if (back_val && ret == 0)
5199 : 59 : ret = 1;
5200 : :
5201 : 2690 : return ret;
5202 : : }
5203 : :
5204 : :
5205 : : /* This function is special since MAX() can take any number of
5206 : : arguments. The simplified expression is a rewritten version of the
5207 : : argument list containing at most one constant element. Other
5208 : : constant elements are deleted. Because the argument list has
5209 : : already been checked, this function always succeeds. sign is 1 for
5210 : : MAX(), -1 for MIN(). */
5211 : :
5212 : : static gfc_expr *
5213 : 5828 : simplify_min_max (gfc_expr *expr, int sign)
5214 : : {
5215 : 5828 : int tmp1, tmp2;
5216 : 5828 : gfc_actual_arglist *arg, *last, *extremum;
5217 : 5828 : gfc_expr *tmp, *ret;
5218 : 5828 : const char *fname;
5219 : :
5220 : 5828 : last = NULL;
5221 : 5828 : extremum = NULL;
5222 : :
5223 : 5828 : arg = expr->value.function.actual;
5224 : :
5225 : 18770 : for (; arg; last = arg, arg = arg->next)
5226 : : {
5227 : 12942 : if (arg->expr->expr_type != EXPR_CONSTANT)
5228 : 7431 : continue;
5229 : :
5230 : 5511 : if (extremum == NULL)
5231 : : {
5232 : 3448 : extremum = arg;
5233 : 3448 : continue;
5234 : : }
5235 : :
5236 : 2063 : min_max_choose (arg->expr, extremum->expr, sign);
5237 : :
5238 : : /* Delete the extra constant argument. */
5239 : 2063 : last->next = arg->next;
5240 : :
5241 : 2063 : arg->next = NULL;
5242 : 2063 : gfc_free_actual_arglist (arg);
5243 : 2063 : arg = last;
5244 : : }
5245 : :
5246 : : /* If there is one value left, replace the function call with the
5247 : : expression. */
5248 : 5828 : if (expr->value.function.actual->next != NULL)
5249 : : return NULL;
5250 : :
5251 : : /* Handle special cases of specific functions (min|max)1 and
5252 : : a(min|max)0. */
5253 : :
5254 : 1682 : tmp = expr->value.function.actual->expr;
5255 : 1682 : fname = expr->value.function.isym->name;
5256 : :
5257 : 1682 : if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind)
5258 : 572 : && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0))
5259 : : {
5260 : : /* Explicit conversion, turn off -Wconversion and -Wconversion-extra
5261 : : warnings. */
5262 : 15 : tmp1 = warn_conversion;
5263 : 15 : tmp2 = warn_conversion_extra;
5264 : 15 : warn_conversion = warn_conversion_extra = 0;
5265 : :
5266 : 15 : ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind);
5267 : :
5268 : 15 : warn_conversion = tmp1;
5269 : 15 : warn_conversion_extra = tmp2;
5270 : : }
5271 : 1667 : else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind)
5272 : 1450 : && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0))
5273 : : {
5274 : 15 : ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind);
5275 : : }
5276 : : else
5277 : 1652 : ret = gfc_copy_expr (tmp);
5278 : :
5279 : : return ret;
5280 : :
5281 : : }
5282 : :
5283 : :
5284 : : gfc_expr *
5285 : 1843 : gfc_simplify_min (gfc_expr *e)
5286 : : {
5287 : 1843 : return simplify_min_max (e, -1);
5288 : : }
5289 : :
5290 : :
5291 : : gfc_expr *
5292 : 3985 : gfc_simplify_max (gfc_expr *e)
5293 : : {
5294 : 3985 : return simplify_min_max (e, 1);
5295 : : }
5296 : :
5297 : : /* Helper function for gfc_simplify_minval. */
5298 : :
5299 : : static gfc_expr *
5300 : 169 : gfc_min (gfc_expr *op1, gfc_expr *op2)
5301 : : {
5302 : 169 : min_max_choose (op1, op2, -1);
5303 : 169 : gfc_free_expr (op1);
5304 : 169 : return op2;
5305 : : }
5306 : :
5307 : : /* Simplify minval for constant arrays. */
5308 : :
5309 : : gfc_expr *
5310 : 3939 : gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5311 : : {
5312 : 3939 : return simplify_transformation (array, dim, mask, INT_MAX, gfc_min);
5313 : : }
5314 : :
5315 : : /* Helper function for gfc_simplify_maxval. */
5316 : :
5317 : : static gfc_expr *
5318 : 145 : gfc_max (gfc_expr *op1, gfc_expr *op2)
5319 : : {
5320 : 145 : min_max_choose (op1, op2, 1);
5321 : 145 : gfc_free_expr (op1);
5322 : 145 : return op2;
5323 : : }
5324 : :
5325 : :
5326 : : /* Simplify maxval for constant arrays. */
5327 : :
5328 : : gfc_expr *
5329 : 2818 : gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5330 : : {
5331 : 2818 : return simplify_transformation (array, dim, mask, INT_MIN, gfc_max);
5332 : : }
5333 : :
5334 : :
5335 : : /* Transform minloc or maxloc of an array, according to MASK,
5336 : : to the scalar result. This code is mostly identical to
5337 : : simplify_transformation_to_scalar. */
5338 : :
5339 : : static gfc_expr *
5340 : 58 : simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
5341 : : gfc_expr *extremum, int sign, bool back_val)
5342 : : {
5343 : 58 : gfc_expr *a, *m;
5344 : 58 : gfc_constructor *array_ctor, *mask_ctor;
5345 : 58 : mpz_t count;
5346 : :
5347 : 58 : mpz_set_si (result->value.integer, 0);
5348 : :
5349 : :
5350 : : /* Shortcut for constant .FALSE. MASK. */
5351 : 58 : if (mask
5352 : 42 : && mask->expr_type == EXPR_CONSTANT
5353 : 36 : && !mask->value.logical)
5354 : : return result;
5355 : :
5356 : 22 : array_ctor = gfc_constructor_first (array->value.constructor);
5357 : 22 : if (mask && mask->expr_type == EXPR_ARRAY)
5358 : 6 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5359 : : else
5360 : : mask_ctor = NULL;
5361 : :
5362 : 22 : mpz_init_set_si (count, 0);
5363 : 132 : while (array_ctor)
5364 : : {
5365 : 88 : mpz_add_ui (count, count, 1);
5366 : 88 : a = array_ctor->expr;
5367 : 88 : array_ctor = gfc_constructor_next (array_ctor);
5368 : : /* A constant MASK equals .TRUE. here and can be ignored. */
5369 : 88 : if (mask_ctor)
5370 : : {
5371 : 28 : m = mask_ctor->expr;
5372 : 28 : mask_ctor = gfc_constructor_next (mask_ctor);
5373 : 28 : if (!m->value.logical)
5374 : 12 : continue;
5375 : : }
5376 : 76 : if (min_max_choose (a, extremum, sign, back_val) > 0)
5377 : 36 : mpz_set (result->value.integer, count);
5378 : : }
5379 : 22 : mpz_clear (count);
5380 : 22 : gfc_free_expr (extremum);
5381 : 22 : return result;
5382 : : }
5383 : :
5384 : : /* Simplify minloc / maxloc in the absence of a dim argument. */
5385 : :
5386 : : static gfc_expr *
5387 : 69 : simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
5388 : : gfc_expr *array, gfc_expr *mask, int sign,
5389 : : bool back_val)
5390 : : {
5391 : 69 : ssize_t res[GFC_MAX_DIMENSIONS];
5392 : 69 : int i, n;
5393 : 69 : gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5394 : 69 : ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5395 : : sstride[GFC_MAX_DIMENSIONS];
5396 : 69 : gfc_expr *a, *m;
5397 : 69 : bool continue_loop;
5398 : 69 : bool ma;
5399 : :
5400 : 154 : for (i = 0; i<array->rank; i++)
5401 : 85 : res[i] = -1;
5402 : :
5403 : : /* Shortcut for constant .FALSE. MASK. */
5404 : 69 : if (mask
5405 : 56 : && mask->expr_type == EXPR_CONSTANT
5406 : 40 : && !mask->value.logical)
5407 : 38 : goto finish;
5408 : :
5409 : 31 : if (array->shape == NULL)
5410 : 1 : goto finish;
5411 : :
5412 : 66 : for (i = 0; i < array->rank; i++)
5413 : : {
5414 : 44 : count[i] = 0;
5415 : 44 : sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5416 : 44 : extent[i] = mpz_get_si (array->shape[i]);
5417 : 44 : if (extent[i] <= 0)
5418 : 8 : goto finish;
5419 : : }
5420 : :
5421 : 22 : continue_loop = true;
5422 : 22 : array_ctor = gfc_constructor_first (array->value.constructor);
5423 : 22 : if (mask && mask->rank > 0)
5424 : 12 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5425 : : else
5426 : : mask_ctor = NULL;
5427 : :
5428 : : /* Loop over the array elements (and mask), keeping track of
5429 : : the indices to return. */
5430 : 66 : while (continue_loop)
5431 : : {
5432 : 120 : do
5433 : : {
5434 : 120 : a = array_ctor->expr;
5435 : 120 : if (mask_ctor)
5436 : : {
5437 : 46 : m = mask_ctor->expr;
5438 : 46 : ma = m->value.logical;
5439 : 46 : mask_ctor = gfc_constructor_next (mask_ctor);
5440 : : }
5441 : : else
5442 : : ma = true;
5443 : :
5444 : 120 : if (ma && min_max_choose (a, extremum, sign, back_val) > 0)
5445 : : {
5446 : 130 : for (i = 0; i<array->rank; i++)
5447 : 86 : res[i] = count[i];
5448 : : }
5449 : 120 : array_ctor = gfc_constructor_next (array_ctor);
5450 : 120 : count[0] ++;
5451 : 120 : } while (count[0] != extent[0]);
5452 : : n = 0;
5453 : 58 : do
5454 : : {
5455 : : /* When we get to the end of a dimension, reset it and increment
5456 : : the next dimension. */
5457 : 58 : count[n] = 0;
5458 : 58 : n++;
5459 : 58 : if (n >= array->rank)
5460 : : {
5461 : : continue_loop = false;
5462 : : break;
5463 : : }
5464 : : else
5465 : 36 : count[n] ++;
5466 : 36 : } while (count[n] == extent[n]);
5467 : : }
5468 : :
5469 : 22 : finish:
5470 : 69 : gfc_free_expr (extremum);
5471 : 69 : result_ctor = gfc_constructor_first (result->value.constructor);
5472 : 154 : for (i = 0; i<array->rank; i++)
5473 : : {
5474 : 85 : gfc_expr *r_expr;
5475 : 85 : r_expr = result_ctor->expr;
5476 : 85 : mpz_set_si (r_expr->value.integer, res[i] + 1);
5477 : 85 : result_ctor = gfc_constructor_next (result_ctor);
5478 : : }
5479 : 69 : return result;
5480 : : }
5481 : :
5482 : : /* Helper function for gfc_simplify_minmaxloc - build an array
5483 : : expression with n elements. */
5484 : :
5485 : : static gfc_expr *
5486 : 86 : new_array (bt type, int kind, int n, locus *where)
5487 : : {
5488 : 86 : gfc_expr *result;
5489 : 86 : int i;
5490 : :
5491 : 86 : result = gfc_get_array_expr (type, kind, where);
5492 : 86 : result->rank = 1;
5493 : 86 : result->shape = gfc_get_shape(1);
5494 : 86 : mpz_init_set_si (result->shape[0], n);
5495 : 281 : for (i = 0; i < n; i++)
5496 : : {
5497 : 109 : gfc_constructor_append_expr (&result->value.constructor,
5498 : : gfc_get_constant_expr (type, kind, where),
5499 : : NULL);
5500 : : }
5501 : :
5502 : 86 : return result;
5503 : : }
5504 : :
5505 : : /* Simplify minloc and maxloc. This code is mostly identical to
5506 : : simplify_transformation_to_array. */
5507 : :
5508 : : static gfc_expr *
5509 : 24 : simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
5510 : : gfc_expr *dim, gfc_expr *mask,
5511 : : gfc_expr *extremum, int sign, bool back_val)
5512 : : {
5513 : 24 : mpz_t size;
5514 : 24 : int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5515 : 24 : gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5516 : 24 : gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5517 : :
5518 : 24 : int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5519 : : sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
5520 : : tmpstride[GFC_MAX_DIMENSIONS];
5521 : :
5522 : : /* Shortcut for constant .FALSE. MASK. */
5523 : 24 : if (mask
5524 : 10 : && mask->expr_type == EXPR_CONSTANT
5525 : 0 : && !mask->value.logical)
5526 : : return result;
5527 : :
5528 : : /* Build an indexed table for array element expressions to minimize
5529 : : linked-list traversal. Masked elements are set to NULL. */
5530 : 24 : gfc_array_size (array, &size);
5531 : 24 : arraysize = mpz_get_ui (size);
5532 : 24 : mpz_clear (size);
5533 : :
5534 : 24 : arrayvec = XCNEWVEC (gfc_expr*, arraysize);
5535 : :
5536 : 24 : array_ctor = gfc_constructor_first (array->value.constructor);
5537 : 24 : mask_ctor = NULL;
5538 : 24 : if (mask && mask->expr_type == EXPR_ARRAY)
5539 : 10 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5540 : :
5541 : 234 : for (i = 0; i < arraysize; ++i)
5542 : : {
5543 : 210 : arrayvec[i] = array_ctor->expr;
5544 : 210 : array_ctor = gfc_constructor_next (array_ctor);
5545 : :
5546 : 210 : if (mask_ctor)
5547 : : {
5548 : 106 : if (!mask_ctor->expr->value.logical)
5549 : 65 : arrayvec[i] = NULL;
5550 : :
5551 : 106 : mask_ctor = gfc_constructor_next (mask_ctor);
5552 : : }
5553 : : }
5554 : :
5555 : : /* Same for the result expression. */
5556 : 24 : gfc_array_size (result, &size);
5557 : 24 : resultsize = mpz_get_ui (size);
5558 : 24 : mpz_clear (size);
5559 : :
5560 : 24 : resultvec = XCNEWVEC (gfc_expr*, resultsize);
5561 : 24 : result_ctor = gfc_constructor_first (result->value.constructor);
5562 : 114 : for (i = 0; i < resultsize; ++i)
5563 : : {
5564 : 66 : resultvec[i] = result_ctor->expr;
5565 : 66 : result_ctor = gfc_constructor_next (result_ctor);
5566 : : }
5567 : :
5568 : 24 : gfc_extract_int (dim, &dim_index);
5569 : 24 : dim_index -= 1; /* zero-base index */
5570 : 24 : dim_extent = 0;
5571 : 24 : dim_stride = 0;
5572 : :
5573 : 72 : for (i = 0, n = 0; i < array->rank; ++i)
5574 : : {
5575 : 48 : count[i] = 0;
5576 : 48 : tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
5577 : 48 : if (i == dim_index)
5578 : : {
5579 : 24 : dim_extent = mpz_get_si (array->shape[i]);
5580 : 24 : dim_stride = tmpstride[i];
5581 : 24 : continue;
5582 : : }
5583 : :
5584 : 24 : extent[n] = mpz_get_si (array->shape[i]);
5585 : 24 : sstride[n] = tmpstride[i];
5586 : 24 : dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5587 : 24 : n += 1;
5588 : : }
5589 : :
5590 : 24 : done = resultsize <= 0;
5591 : 24 : base = arrayvec;
5592 : 24 : dest = resultvec;
5593 : 90 : while (!done)
5594 : : {
5595 : 66 : gfc_expr *ex;
5596 : 66 : ex = gfc_copy_expr (extremum);
5597 : 342 : for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5598 : : {
5599 : 210 : if (*src && min_max_choose (*src, ex, sign, back_val) > 0)
5600 : 107 : mpz_set_si ((*dest)->value.integer, n + 1);
5601 : : }
5602 : :
5603 : 66 : count[0]++;
5604 : 66 : base += sstride[0];
5605 : 66 : dest += dstride[0];
5606 : 66 : gfc_free_expr (ex);
5607 : :
5608 : 66 : n = 0;
5609 : 154 : while (!done && count[n] == extent[n])
5610 : : {
5611 : 22 : count[n] = 0;
5612 : 22 : base -= sstride[n] * extent[n];
5613 : 22 : dest -= dstride[n] * extent[n];
5614 : :
5615 : 22 : n++;
5616 : 22 : if (n < result->rank)
5617 : : {
5618 : : /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5619 : : times, we'd warn for the last iteration, because the
5620 : : array index will have already been incremented to the
5621 : : array sizes, and we can't tell that this must make
5622 : : the test against result->rank false, because ranks
5623 : : must not exceed GFC_MAX_DIMENSIONS. */
5624 : 0 : GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5625 : 0 : count[n]++;
5626 : 0 : base += sstride[n];
5627 : 0 : dest += dstride[n];
5628 : 0 : GCC_DIAGNOSTIC_POP
5629 : : }
5630 : : else
5631 : : done = true;
5632 : : }
5633 : : }
5634 : :
5635 : : /* Place updated expression in result constructor. */
5636 : 24 : result_ctor = gfc_constructor_first (result->value.constructor);
5637 : 114 : for (i = 0; i < resultsize; ++i)
5638 : : {
5639 : 66 : result_ctor->expr = resultvec[i];
5640 : 66 : result_ctor = gfc_constructor_next (result_ctor);
5641 : : }
5642 : :
5643 : 24 : free (arrayvec);
5644 : 24 : free (resultvec);
5645 : 24 : free (extremum);
5646 : 24 : return result;
5647 : : }
5648 : :
5649 : : /* Simplify minloc and maxloc for constant arrays. */
5650 : :
5651 : : static gfc_expr *
5652 : 9644 : gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
5653 : : gfc_expr *kind, gfc_expr *back, int sign)
5654 : : {
5655 : 9644 : gfc_expr *result;
5656 : 9644 : gfc_expr *extremum;
5657 : 9644 : int ikind;
5658 : 9644 : int init_val;
5659 : 9644 : bool back_val = false;
5660 : :
5661 : 9644 : if (!is_constant_array_expr (array)
5662 : 9644 : || !gfc_is_constant_expr (dim))
5663 : 9385 : return NULL;
5664 : :
5665 : 259 : if (mask
5666 : 216 : && !is_constant_array_expr (mask)
5667 : 443 : && mask->expr_type != EXPR_CONSTANT)
5668 : : return NULL;
5669 : :
5670 : 151 : if (kind)
5671 : : {
5672 : 0 : if (gfc_extract_int (kind, &ikind, -1))
5673 : : return NULL;
5674 : : }
5675 : : else
5676 : 151 : ikind = gfc_default_integer_kind;
5677 : :
5678 : 151 : if (back)
5679 : : {
5680 : 151 : if (back->expr_type != EXPR_CONSTANT)
5681 : : return NULL;
5682 : :
5683 : 151 : back_val = back->value.logical;
5684 : : }
5685 : :
5686 : 151 : if (sign < 0)
5687 : : init_val = INT_MAX;
5688 : 77 : else if (sign > 0)
5689 : : init_val = INT_MIN;
5690 : : else
5691 : 0 : gcc_unreachable();
5692 : :
5693 : 151 : extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
5694 : 151 : init_result_expr (extremum, init_val, array);
5695 : :
5696 : 151 : if (dim)
5697 : : {
5698 : 82 : result = transformational_result (array, dim, BT_INTEGER,
5699 : : ikind, &array->where);
5700 : 82 : init_result_expr (result, 0, array);
5701 : :
5702 : 82 : if (array->rank == 1)
5703 : 58 : return simplify_minmaxloc_to_scalar (result, array, mask, extremum,
5704 : 58 : sign, back_val);
5705 : : else
5706 : 24 : return simplify_minmaxloc_to_array (result, array, dim, mask, extremum,
5707 : 24 : sign, back_val);
5708 : : }
5709 : : else
5710 : : {
5711 : 69 : result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
5712 : 69 : return simplify_minmaxloc_nodim (result, extremum, array, mask,
5713 : 69 : sign, back_val);
5714 : : }
5715 : : }
5716 : :
5717 : : gfc_expr *
5718 : 5693 : gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5719 : : gfc_expr *back)
5720 : : {
5721 : 5693 : return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1);
5722 : : }
5723 : :
5724 : : gfc_expr *
5725 : 3951 : gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5726 : : gfc_expr *back)
5727 : : {
5728 : 3951 : return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
5729 : : }
5730 : :
5731 : : /* Simplify findloc to scalar. Similar to
5732 : : simplify_minmaxloc_to_scalar. */
5733 : :
5734 : : static gfc_expr *
5735 : 8 : simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5736 : : gfc_expr *mask, int back_val)
5737 : : {
5738 : 8 : gfc_expr *a, *m;
5739 : 8 : gfc_constructor *array_ctor, *mask_ctor;
5740 : 8 : mpz_t count;
5741 : :
5742 : 8 : mpz_set_si (result->value.integer, 0);
5743 : :
5744 : : /* Shortcut for constant .FALSE. MASK. */
5745 : 8 : if (mask
5746 : 2 : && mask->expr_type == EXPR_CONSTANT
5747 : 0 : && !mask->value.logical)
5748 : : return result;
5749 : :
5750 : 8 : array_ctor = gfc_constructor_first (array->value.constructor);
5751 : 8 : if (mask && mask->expr_type == EXPR_ARRAY)
5752 : 2 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5753 : : else
5754 : : mask_ctor = NULL;
5755 : :
5756 : 8 : mpz_init_set_si (count, 0);
5757 : 35 : while (array_ctor)
5758 : : {
5759 : 24 : mpz_add_ui (count, count, 1);
5760 : 24 : a = array_ctor->expr;
5761 : 24 : array_ctor = gfc_constructor_next (array_ctor);
5762 : : /* A constant MASK equals .TRUE. here and can be ignored. */
5763 : 24 : if (mask_ctor)
5764 : : {
5765 : 8 : m = mask_ctor->expr;
5766 : 8 : mask_ctor = gfc_constructor_next (mask_ctor);
5767 : 8 : if (!m->value.logical)
5768 : 2 : continue;
5769 : : }
5770 : 22 : if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5771 : : {
5772 : : /* We have a match. If BACK is true, continue so we find
5773 : : the last one. */
5774 : 8 : mpz_set (result->value.integer, count);
5775 : 8 : if (!back_val)
5776 : : break;
5777 : : }
5778 : : }
5779 : 8 : mpz_clear (count);
5780 : 8 : return result;
5781 : : }
5782 : :
5783 : : /* Simplify findloc in the absence of a dim argument. Similar to
5784 : : simplify_minmaxloc_nodim. */
5785 : :
5786 : : static gfc_expr *
5787 : 17 : simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
5788 : : gfc_expr *mask, bool back_val)
5789 : : {
5790 : 17 : ssize_t res[GFC_MAX_DIMENSIONS];
5791 : 17 : int i, n;
5792 : 17 : gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5793 : 17 : ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5794 : : sstride[GFC_MAX_DIMENSIONS];
5795 : 17 : gfc_expr *a, *m;
5796 : 17 : bool continue_loop;
5797 : 17 : bool ma;
5798 : :
5799 : 41 : for (i = 0; i < array->rank; i++)
5800 : 24 : res[i] = -1;
5801 : :
5802 : : /* Shortcut for constant .FALSE. MASK. */
5803 : 17 : if (mask
5804 : 1 : && mask->expr_type == EXPR_CONSTANT
5805 : 0 : && !mask->value.logical)
5806 : 0 : goto finish;
5807 : :
5808 : 35 : for (i = 0; i < array->rank; i++)
5809 : : {
5810 : 24 : count[i] = 0;
5811 : 24 : sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5812 : 24 : extent[i] = mpz_get_si (array->shape[i]);
5813 : 24 : if (extent[i] <= 0)
5814 : 6 : goto finish;
5815 : : }
5816 : :
5817 : 11 : continue_loop = true;
5818 : 11 : array_ctor = gfc_constructor_first (array->value.constructor);
5819 : 11 : if (mask && mask->rank > 0)
5820 : 1 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5821 : : else
5822 : : mask_ctor = NULL;
5823 : :
5824 : : /* Loop over the array elements (and mask), keeping track of
5825 : : the indices to return. */
5826 : 21 : while (continue_loop)
5827 : : {
5828 : 30 : do
5829 : : {
5830 : 30 : a = array_ctor->expr;
5831 : 30 : if (mask_ctor)
5832 : : {
5833 : 4 : m = mask_ctor->expr;
5834 : 4 : ma = m->value.logical;
5835 : 4 : mask_ctor = gfc_constructor_next (mask_ctor);
5836 : : }
5837 : : else
5838 : : ma = true;
5839 : :
5840 : 30 : if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5841 : : {
5842 : 19 : for (i = 0; i < array->rank; i++)
5843 : 12 : res[i] = count[i];
5844 : 7 : if (!back_val)
5845 : 5 : goto finish;
5846 : : }
5847 : 25 : array_ctor = gfc_constructor_next (array_ctor);
5848 : 25 : count[0] ++;
5849 : 25 : } while (count[0] != extent[0]);
5850 : : n = 0;
5851 : 13 : do
5852 : : {
5853 : : /* When we get to the end of a dimension, reset it and increment
5854 : : the next dimension. */
5855 : 13 : count[n] = 0;
5856 : 13 : n++;
5857 : 13 : if (n >= array->rank)
5858 : : {
5859 : : continue_loop = false;
5860 : : break;
5861 : : }
5862 : : else
5863 : 7 : count[n] ++;
5864 : 7 : } while (count[n] == extent[n]);
5865 : : }
5866 : :
5867 : 6 : finish:
5868 : 17 : result_ctor = gfc_constructor_first (result->value.constructor);
5869 : 41 : for (i = 0; i < array->rank; i++)
5870 : : {
5871 : 24 : gfc_expr *r_expr;
5872 : 24 : r_expr = result_ctor->expr;
5873 : 24 : mpz_set_si (r_expr->value.integer, res[i] + 1);
5874 : 24 : result_ctor = gfc_constructor_next (result_ctor);
5875 : : }
5876 : 17 : return result;
5877 : : }
5878 : :
5879 : :
5880 : : /* Simplify findloc to an array. Similar to
5881 : : simplify_minmaxloc_to_array. */
5882 : :
5883 : : static gfc_expr *
5884 : 2 : simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5885 : : gfc_expr *dim, gfc_expr *mask, bool back_val)
5886 : : {
5887 : 2 : mpz_t size;
5888 : 2 : int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5889 : 2 : gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5890 : 2 : gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5891 : :
5892 : 2 : int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5893 : : sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
5894 : : tmpstride[GFC_MAX_DIMENSIONS];
5895 : :
5896 : : /* Shortcut for constant .FALSE. MASK. */
5897 : 2 : if (mask
5898 : 0 : && mask->expr_type == EXPR_CONSTANT
5899 : 0 : && !mask->value.logical)
5900 : : return result;
5901 : :
5902 : : /* Build an indexed table for array element expressions to minimize
5903 : : linked-list traversal. Masked elements are set to NULL. */
5904 : 2 : gfc_array_size (array, &size);
5905 : 2 : arraysize = mpz_get_ui (size);
5906 : 2 : mpz_clear (size);
5907 : :
5908 : 2 : arrayvec = XCNEWVEC (gfc_expr*, arraysize);
5909 : :
5910 : 2 : array_ctor = gfc_constructor_first (array->value.constructor);
5911 : 2 : mask_ctor = NULL;
5912 : 2 : if (mask && mask->expr_type == EXPR_ARRAY)
5913 : 0 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5914 : :
5915 : 14 : for (i = 0; i < arraysize; ++i)
5916 : : {
5917 : 12 : arrayvec[i] = array_ctor->expr;
5918 : 12 : array_ctor = gfc_constructor_next (array_ctor);
5919 : :
5920 : 12 : if (mask_ctor)
5921 : : {
5922 : 0 : if (!mask_ctor->expr->value.logical)
5923 : 0 : arrayvec[i] = NULL;
5924 : :
5925 : 0 : mask_ctor = gfc_constructor_next (mask_ctor);
5926 : : }
5927 : : }
5928 : :
5929 : : /* Same for the result expression. */
5930 : 2 : gfc_array_size (result, &size);
5931 : 2 : resultsize = mpz_get_ui (size);
5932 : 2 : mpz_clear (size);
5933 : :
5934 : 2 : resultvec = XCNEWVEC (gfc_expr*, resultsize);
5935 : 2 : result_ctor = gfc_constructor_first (result->value.constructor);
5936 : 9 : for (i = 0; i < resultsize; ++i)
5937 : : {
5938 : 5 : resultvec[i] = result_ctor->expr;
5939 : 5 : result_ctor = gfc_constructor_next (result_ctor);
5940 : : }
5941 : :
5942 : 2 : gfc_extract_int (dim, &dim_index);
5943 : :
5944 : 2 : dim_index -= 1; /* Zero-base index. */
5945 : 2 : dim_extent = 0;
5946 : 2 : dim_stride = 0;
5947 : :
5948 : 6 : for (i = 0, n = 0; i < array->rank; ++i)
5949 : : {
5950 : 4 : count[i] = 0;
5951 : 4 : tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
5952 : 4 : if (i == dim_index)
5953 : : {
5954 : 2 : dim_extent = mpz_get_si (array->shape[i]);
5955 : 2 : dim_stride = tmpstride[i];
5956 : 2 : continue;
5957 : : }
5958 : :
5959 : 2 : extent[n] = mpz_get_si (array->shape[i]);
5960 : 2 : sstride[n] = tmpstride[i];
5961 : 2 : dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5962 : 2 : n += 1;
5963 : : }
5964 : :
5965 : 2 : done = resultsize <= 0;
5966 : 2 : base = arrayvec;
5967 : 2 : dest = resultvec;
5968 : 7 : while (!done)
5969 : : {
5970 : 9 : for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5971 : : {
5972 : 8 : if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
5973 : : {
5974 : 4 : mpz_set_si ((*dest)->value.integer, n + 1);
5975 : 4 : if (!back_val)
5976 : : break;
5977 : : }
5978 : : }
5979 : :
5980 : 5 : count[0]++;
5981 : 5 : base += sstride[0];
5982 : 5 : dest += dstride[0];
5983 : :
5984 : 5 : n = 0;
5985 : 7 : while (!done && count[n] == extent[n])
5986 : : {
5987 : 2 : count[n] = 0;
5988 : 2 : base -= sstride[n] * extent[n];
5989 : 2 : dest -= dstride[n] * extent[n];
5990 : :
5991 : 2 : n++;
5992 : 2 : if (n < result->rank)
5993 : : {
5994 : : /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5995 : : times, we'd warn for the last iteration, because the
5996 : : array index will have already been incremented to the
5997 : : array sizes, and we can't tell that this must make
5998 : : the test against result->rank false, because ranks
5999 : : must not exceed GFC_MAX_DIMENSIONS. */
6000 : 0 : GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
6001 : 0 : count[n]++;
6002 : 0 : base += sstride[n];
6003 : 0 : dest += dstride[n];
6004 : 0 : GCC_DIAGNOSTIC_POP
6005 : : }
6006 : : else
6007 : : done = true;
6008 : : }
6009 : : }
6010 : :
6011 : : /* Place updated expression in result constructor. */
6012 : 2 : result_ctor = gfc_constructor_first (result->value.constructor);
6013 : 9 : for (i = 0; i < resultsize; ++i)
6014 : : {
6015 : 5 : result_ctor->expr = resultvec[i];
6016 : 5 : result_ctor = gfc_constructor_next (result_ctor);
6017 : : }
6018 : :
6019 : 2 : free (arrayvec);
6020 : 2 : free (resultvec);
6021 : 2 : return result;
6022 : : }
6023 : :
6024 : : /* Simplify findloc. */
6025 : :
6026 : : gfc_expr *
6027 : 1176 : gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
6028 : : gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
6029 : : {
6030 : 1176 : gfc_expr *result;
6031 : 1176 : int ikind;
6032 : 1176 : bool back_val = false;
6033 : :
6034 : 1176 : if (!is_constant_array_expr (array)
6035 : 30 : || array->shape == NULL
6036 : 1205 : || !gfc_is_constant_expr (dim))
6037 : 1147 : return NULL;
6038 : :
6039 : 29 : if (! gfc_is_constant_expr (value))
6040 : : return 0;
6041 : :
6042 : 29 : if (mask
6043 : 3 : && !is_constant_array_expr (mask)
6044 : 29 : && mask->expr_type != EXPR_CONSTANT)
6045 : : return NULL;
6046 : :
6047 : 29 : if (kind)
6048 : : {
6049 : 0 : if (gfc_extract_int (kind, &ikind, -1))
6050 : : return NULL;
6051 : : }
6052 : : else
6053 : 29 : ikind = gfc_default_integer_kind;
6054 : :
6055 : 29 : if (back)
6056 : : {
6057 : 29 : if (back->expr_type != EXPR_CONSTANT)
6058 : : return NULL;
6059 : :
6060 : 27 : back_val = back->value.logical;
6061 : : }
6062 : :
6063 : 27 : if (dim)
6064 : : {
6065 : 10 : result = transformational_result (array, dim, BT_INTEGER,
6066 : : ikind, &array->where);
6067 : 10 : init_result_expr (result, 0, array);
6068 : :
6069 : 10 : if (array->rank == 1)
6070 : 8 : return simplify_findloc_to_scalar (result, array, value, mask,
6071 : 8 : back_val);
6072 : : else
6073 : 2 : return simplify_findloc_to_array (result, array, value, dim, mask,
6074 : 2 : back_val);
6075 : : }
6076 : : else
6077 : : {
6078 : 17 : result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
6079 : 17 : return simplify_findloc_nodim (result, value, array, mask, back_val);
6080 : : }
6081 : : return NULL;
6082 : : }
6083 : :
6084 : : gfc_expr *
6085 : 1 : gfc_simplify_maxexponent (gfc_expr *x)
6086 : : {
6087 : 1 : int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6088 : 1 : return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
6089 : 1 : gfc_real_kinds[i].max_exponent);
6090 : : }
6091 : :
6092 : :
6093 : : gfc_expr *
6094 : 25 : gfc_simplify_minexponent (gfc_expr *x)
6095 : : {
6096 : 25 : int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6097 : 25 : return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
6098 : 25 : gfc_real_kinds[i].min_exponent);
6099 : : }
6100 : :
6101 : :
6102 : : gfc_expr *
6103 : 266529 : gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
6104 : : {
6105 : 266529 : gfc_expr *result;
6106 : 266529 : int kind;
6107 : :
6108 : : /* First check p. */
6109 : 266529 : if (p->expr_type != EXPR_CONSTANT)
6110 : : return NULL;
6111 : :
6112 : : /* p shall not be 0. */
6113 : 265862 : switch (p->ts.type)
6114 : : {
6115 : 265754 : case BT_INTEGER:
6116 : 265754 : if (mpz_cmp_ui (p->value.integer, 0) == 0)
6117 : : {
6118 : 4 : gfc_error ("Argument %qs of MOD at %L shall not be zero",
6119 : : "P", &p->where);
6120 : 4 : return &gfc_bad_expr;
6121 : : }
6122 : : break;
6123 : 108 : case BT_REAL:
6124 : 108 : if (mpfr_cmp_ui (p->value.real, 0) == 0)
6125 : : {
6126 : 0 : gfc_error ("Argument %qs of MOD at %L shall not be zero",
6127 : : "P", &p->where);
6128 : 0 : return &gfc_bad_expr;
6129 : : }
6130 : : break;
6131 : 0 : default:
6132 : 0 : gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6133 : : }
6134 : :
6135 : 265858 : if (a->expr_type != EXPR_CONSTANT)
6136 : : return NULL;
6137 : :
6138 : 262773 : kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6139 : 262773 : result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6140 : :
6141 : 262773 : if (a->ts.type == BT_INTEGER)
6142 : 262665 : mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
6143 : : else
6144 : : {
6145 : 108 : gfc_set_model_kind (kind);
6146 : 108 : mpfr_fmod (result->value.real, a->value.real, p->value.real,
6147 : : GFC_RND_MODE);
6148 : : }
6149 : :
6150 : 262773 : return range_check (result, "MOD");
6151 : : }
6152 : :
6153 : :
6154 : : gfc_expr *
6155 : 2020 : gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
6156 : : {
6157 : 2020 : gfc_expr *result;
6158 : 2020 : int kind;
6159 : :
6160 : : /* First check p. */
6161 : 2020 : if (p->expr_type != EXPR_CONSTANT)
6162 : : return NULL;
6163 : :
6164 : : /* p shall not be 0. */
6165 : 1865 : switch (p->ts.type)
6166 : : {
6167 : 1829 : case BT_INTEGER:
6168 : 1829 : if (mpz_cmp_ui (p->value.integer, 0) == 0)
6169 : : {
6170 : 4 : gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6171 : : "P", &p->where);
6172 : 4 : return &gfc_bad_expr;
6173 : : }
6174 : : break;
6175 : 36 : case BT_REAL:
6176 : 36 : if (mpfr_cmp_ui (p->value.real, 0) == 0)
6177 : : {
6178 : 0 : gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6179 : : "P", &p->where);
6180 : 0 : return &gfc_bad_expr;
6181 : : }
6182 : : break;
6183 : 0 : default:
6184 : 0 : gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6185 : : }
6186 : :
6187 : 1861 : if (a->expr_type != EXPR_CONSTANT)
6188 : : return NULL;
6189 : :
6190 : 234 : kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6191 : 234 : result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6192 : :
6193 : 234 : if (a->ts.type == BT_INTEGER)
6194 : 198 : mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
6195 : : else
6196 : : {
6197 : 36 : gfc_set_model_kind (kind);
6198 : 36 : mpfr_fmod (result->value.real, a->value.real, p->value.real,
6199 : : GFC_RND_MODE);
6200 : 36 : if (mpfr_cmp_ui (result->value.real, 0) != 0)
6201 : : {
6202 : 12 : if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
6203 : 6 : mpfr_add (result->value.real, result->value.real, p->value.real,
6204 : : GFC_RND_MODE);
6205 : : }
6206 : : else
6207 : 24 : mpfr_copysign (result->value.real, result->value.real,
6208 : : p->value.real, GFC_RND_MODE);
6209 : : }
6210 : :
6211 : 234 : return range_check (result, "MODULO");
6212 : : }
6213 : :
6214 : :
6215 : : gfc_expr *
6216 : 6320 : gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
6217 : : {
6218 : 6320 : gfc_expr *result;
6219 : 6320 : mpfr_exp_t emin, emax;
6220 : 6320 : int kind;
6221 : :
6222 : 6320 : if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
6223 : : return NULL;
6224 : :
6225 : 826 : result = gfc_copy_expr (x);
6226 : :
6227 : : /* Save current values of emin and emax. */
6228 : 826 : emin = mpfr_get_emin ();
6229 : 826 : emax = mpfr_get_emax ();
6230 : :
6231 : : /* Set emin and emax for the current model number. */
6232 : 826 : kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
6233 : 826 : mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent -
6234 : 826 : mpfr_get_prec(result->value.real) + 1);
6235 : 826 : mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent);
6236 : 826 : mpfr_check_range (result->value.real, 0, MPFR_RNDU);
6237 : :
6238 : 826 : if (mpfr_sgn (s->value.real) > 0)
6239 : : {
6240 : 404 : mpfr_nextabove (result->value.real);
6241 : 404 : mpfr_subnormalize (result->value.real, 0, MPFR_RNDU);
6242 : : }
6243 : : else
6244 : : {
6245 : 422 : mpfr_nextbelow (result->value.real);
6246 : 422 : mpfr_subnormalize (result->value.real, 0, MPFR_RNDD);
6247 : : }
6248 : :
6249 : 826 : mpfr_set_emin (emin);
6250 : 826 : mpfr_set_emax (emax);
6251 : :
6252 : : /* Only NaN can occur. Do not use range check as it gives an
6253 : : error for denormal numbers. */
6254 : 826 : if (mpfr_nan_p (result->value.real) && flag_range_check)
6255 : : {
6256 : 0 : gfc_error ("Result of NEAREST is NaN at %L", &result->where);
6257 : 0 : gfc_free_expr (result);
6258 : 0 : return &gfc_bad_expr;
6259 : : }
6260 : :
6261 : : return result;
6262 : : }
6263 : :
6264 : :
6265 : : static gfc_expr *
6266 : 520 : simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
6267 : : {
6268 : 520 : gfc_expr *itrunc, *result;
6269 : 520 : int kind;
6270 : :
6271 : 520 : kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
6272 : 520 : if (kind == -1)
6273 : : return &gfc_bad_expr;
6274 : :
6275 : 520 : if (e->expr_type != EXPR_CONSTANT)
6276 : : return NULL;
6277 : :
6278 : 156 : itrunc = gfc_copy_expr (e);
6279 : 156 : mpfr_round (itrunc->value.real, e->value.real);
6280 : :
6281 : 156 : result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
6282 : 156 : gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
6283 : :
6284 : 156 : gfc_free_expr (itrunc);
6285 : :
6286 : 156 : return range_check (result, name);
6287 : : }
6288 : :
6289 : :
6290 : : gfc_expr *
6291 : 331 : gfc_simplify_new_line (gfc_expr *e)
6292 : : {
6293 : 331 : gfc_expr *result;
6294 : :
6295 : 331 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
6296 : 331 : result->value.character.string[0] = '\n';
6297 : :
6298 : 331 : return result;
6299 : : }
6300 : :
6301 : :
6302 : : gfc_expr *
6303 : 388 : gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
6304 : : {
6305 : 388 : return simplify_nint ("NINT", e, k);
6306 : : }
6307 : :
6308 : :
6309 : : gfc_expr *
6310 : 132 : gfc_simplify_idnint (gfc_expr *e)
6311 : : {
6312 : 132 : return simplify_nint ("IDNINT", e, NULL);
6313 : : }
6314 : :
6315 : : static int norm2_scale;
6316 : :
6317 : : static gfc_expr *
6318 : 124 : norm2_add_squared (gfc_expr *result, gfc_expr *e)
6319 : : {
6320 : 124 : mpfr_t tmp;
6321 : :
6322 : 124 : gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6323 : 124 : gcc_assert (result->ts.type == BT_REAL
6324 : : && result->expr_type == EXPR_CONSTANT);
6325 : :
6326 : 124 : gfc_set_model_kind (result->ts.kind);
6327 : 124 : int index = gfc_validate_kind (BT_REAL, result->ts.kind, false);
6328 : 124 : mpfr_exp_t exp;
6329 : 124 : if (mpfr_regular_p (result->value.real))
6330 : : {
6331 : 61 : exp = mpfr_get_exp (result->value.real);
6332 : : /* If result is getting close to overflowing, scale down. */
6333 : 61 : if (exp >= gfc_real_kinds[index].max_exponent - 4
6334 : 0 : && norm2_scale <= gfc_real_kinds[index].max_exponent - 2)
6335 : : {
6336 : 0 : norm2_scale += 2;
6337 : 0 : mpfr_div_ui (result->value.real, result->value.real, 16,
6338 : : GFC_RND_MODE);
6339 : : }
6340 : : }
6341 : :
6342 : 124 : mpfr_init (tmp);
6343 : 124 : if (mpfr_regular_p (e->value.real))
6344 : : {
6345 : 88 : exp = mpfr_get_exp (e->value.real);
6346 : : /* If e**2 would overflow or close to overflowing, scale down. */
6347 : 88 : if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2)
6348 : : {
6349 : 12 : int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4;
6350 : 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6351 : 12 : mpfr_set_exp (tmp, new_scale - norm2_scale);
6352 : 12 : mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6353 : 12 : mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6354 : 12 : norm2_scale = new_scale;
6355 : : }
6356 : : }
6357 : 124 : if (norm2_scale)
6358 : : {
6359 : 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6360 : 12 : mpfr_set_exp (tmp, norm2_scale);
6361 : 12 : mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE);
6362 : : }
6363 : : else
6364 : 112 : mpfr_set (tmp, e->value.real, GFC_RND_MODE);
6365 : 124 : mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE);
6366 : 124 : mpfr_add (result->value.real, result->value.real, tmp,
6367 : : GFC_RND_MODE);
6368 : 124 : mpfr_clear (tmp);
6369 : :
6370 : 124 : return result;
6371 : : }
6372 : :
6373 : :
6374 : : static gfc_expr *
6375 : 2 : norm2_do_sqrt (gfc_expr *result, gfc_expr *e)
6376 : : {
6377 : 2 : gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6378 : 2 : gcc_assert (result->ts.type == BT_REAL
6379 : : && result->expr_type == EXPR_CONSTANT);
6380 : :
6381 : 2 : if (result != e)
6382 : 0 : mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
6383 : 2 : mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6384 : 2 : if (norm2_scale && mpfr_regular_p (result->value.real))
6385 : : {
6386 : 0 : mpfr_t tmp;
6387 : 0 : mpfr_init (tmp);
6388 : 0 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6389 : 0 : mpfr_set_exp (tmp, norm2_scale);
6390 : 0 : mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6391 : 0 : mpfr_clear (tmp);
6392 : : }
6393 : 2 : norm2_scale = 0;
6394 : :
6395 : 2 : return result;
6396 : : }
6397 : :
6398 : :
6399 : : gfc_expr *
6400 : 449 : gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
6401 : : {
6402 : 449 : gfc_expr *result;
6403 : 449 : bool size_zero;
6404 : :
6405 : 449 : size_zero = gfc_is_size_zero_array (e);
6406 : :
6407 : 835 : if (!(is_constant_array_expr (e) || size_zero)
6408 : 449 : || (dim != NULL && !gfc_is_constant_expr (dim)))
6409 : 386 : return NULL;
6410 : :
6411 : 63 : result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
6412 : 63 : init_result_expr (result, 0, NULL);
6413 : :
6414 : 63 : if (size_zero)
6415 : : return result;
6416 : :
6417 : 38 : norm2_scale = 0;
6418 : 38 : if (!dim || e->rank == 1)
6419 : : {
6420 : 37 : result = simplify_transformation_to_scalar (result, e, NULL,
6421 : : norm2_add_squared);
6422 : 37 : mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6423 : 37 : if (norm2_scale && mpfr_regular_p (result->value.real))
6424 : : {
6425 : 12 : mpfr_t tmp;
6426 : 12 : mpfr_init (tmp);
6427 : 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6428 : 12 : mpfr_set_exp (tmp, norm2_scale);
6429 : 12 : mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6430 : 12 : mpfr_clear (tmp);
6431 : : }
6432 : 37 : norm2_scale = 0;
6433 : 37 : }
6434 : : else
6435 : 1 : result = simplify_transformation_to_array (result, e, dim, NULL,
6436 : : norm2_add_squared,
6437 : : norm2_do_sqrt);
6438 : :
6439 : : return result;
6440 : : }
6441 : :
6442 : :
6443 : : gfc_expr *
6444 : 572 : gfc_simplify_not (gfc_expr *e)
6445 : : {
6446 : 572 : gfc_expr *result;
6447 : :
6448 : 572 : if (e->expr_type != EXPR_CONSTANT)
6449 : : return NULL;
6450 : :
6451 : 198 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6452 : 198 : mpz_com (result->value.integer, e->value.integer);
6453 : :
6454 : 198 : return range_check (result, "NOT");
6455 : : }
6456 : :
6457 : :
6458 : : gfc_expr *
6459 : 1415 : gfc_simplify_null (gfc_expr *mold)
6460 : : {
6461 : 1415 : gfc_expr *result;
6462 : :
6463 : 1415 : if (mold)
6464 : : {
6465 : 280 : result = gfc_copy_expr (mold);
6466 : 280 : result->expr_type = EXPR_NULL;
6467 : : }
6468 : : else
6469 : 1135 : result = gfc_get_null_expr (NULL);
6470 : :
6471 : 1415 : return result;
6472 : : }
6473 : :
6474 : :
6475 : : gfc_expr *
6476 : 1166 : gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
6477 : : {
6478 : 1166 : gfc_expr *result;
6479 : :
6480 : 1166 : if (flag_coarray == GFC_FCOARRAY_NONE)
6481 : : {
6482 : 0 : gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6483 : : return &gfc_bad_expr;
6484 : : }
6485 : :
6486 : 1166 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
6487 : : return NULL;
6488 : :
6489 : 379 : if (failed && failed->expr_type != EXPR_CONSTANT)
6490 : : return NULL;
6491 : :
6492 : : /* FIXME: gfc_current_locus is wrong. */
6493 : 379 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6494 : : &gfc_current_locus);
6495 : :
6496 : 379 : if (failed && failed->value.logical != 0)
6497 : 1 : mpz_set_si (result->value.integer, 0);
6498 : : else
6499 : 378 : mpz_set_si (result->value.integer, 1);
6500 : :
6501 : : return result;
6502 : : }
6503 : :
6504 : :
6505 : : gfc_expr *
6506 : 20 : gfc_simplify_or (gfc_expr *x, gfc_expr *y)
6507 : : {
6508 : 20 : gfc_expr *result;
6509 : 20 : int kind;
6510 : :
6511 : 20 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6512 : : return NULL;
6513 : :
6514 : 6 : kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6515 : :
6516 : 6 : switch (x->ts.type)
6517 : : {
6518 : 0 : case BT_INTEGER:
6519 : 0 : result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6520 : 0 : mpz_ior (result->value.integer, x->value.integer, y->value.integer);
6521 : 0 : return range_check (result, "OR");
6522 : :
6523 : 6 : case BT_LOGICAL:
6524 : 6 : return gfc_get_logical_expr (kind, &x->where,
6525 : 12 : x->value.logical || y->value.logical);
6526 : 0 : default:
6527 : 0 : gcc_unreachable();
6528 : : }
6529 : : }
6530 : :
6531 : :
6532 : : gfc_expr *
6533 : 975 : gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
6534 : : {
6535 : 975 : gfc_expr *result;
6536 : 975 : gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
6537 : :
6538 : 975 : if (!is_constant_array_expr (array)
6539 : 58 : || !is_constant_array_expr (vector)
6540 : 1033 : || (!gfc_is_constant_expr (mask)
6541 : 2 : && !is_constant_array_expr (mask)))
6542 : 918 : return NULL;
6543 : :
6544 : 57 : result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
6545 : 57 : if (array->ts.type == BT_DERIVED)
6546 : 5 : result->ts.u.derived = array->ts.u.derived;
6547 : :
6548 : 57 : array_ctor = gfc_constructor_first (array->value.constructor);
6549 : 114 : vector_ctor = vector
6550 : 57 : ? gfc_constructor_first (vector->value.constructor)
6551 : : : NULL;
6552 : :
6553 : 57 : if (mask->expr_type == EXPR_CONSTANT
6554 : 0 : && mask->value.logical)
6555 : : {
6556 : : /* Copy all elements of ARRAY to RESULT. */
6557 : 0 : while (array_ctor)
6558 : : {
6559 : 0 : gfc_constructor_append_expr (&result->value.constructor,
6560 : : gfc_copy_expr (array_ctor->expr),
6561 : : NULL);
6562 : :
6563 : 0 : array_ctor = gfc_constructor_next (array_ctor);
6564 : 0 : vector_ctor = gfc_constructor_next (vector_ctor);
6565 : : }
6566 : : }
6567 : 57 : else if (mask->expr_type == EXPR_ARRAY)
6568 : : {
6569 : : /* Copy only those elements of ARRAY to RESULT whose
6570 : : MASK equals .TRUE.. */
6571 : 57 : mask_ctor = gfc_constructor_first (mask->value.constructor);
6572 : 303 : while (mask_ctor && array_ctor)
6573 : : {
6574 : 189 : if (mask_ctor->expr->value.logical)
6575 : : {
6576 : 130 : gfc_constructor_append_expr (&result->value.constructor,
6577 : : gfc_copy_expr (array_ctor->expr),
6578 : : NULL);
6579 : 130 : vector_ctor = gfc_constructor_next (vector_ctor);
6580 : : }
6581 : :
6582 : 189 : array_ctor = gfc_constructor_next (array_ctor);
6583 : 189 : mask_ctor = gfc_constructor_next (mask_ctor);
6584 : : }
6585 : : }
6586 : :
6587 : : /* Append any left-over elements from VECTOR to RESULT. */
6588 : 85 : while (vector_ctor)
6589 : : {
6590 : 28 : gfc_constructor_append_expr (&result->value.constructor,
6591 : : gfc_copy_expr (vector_ctor->expr),
6592 : : NULL);
6593 : 28 : vector_ctor = gfc_constructor_next (vector_ctor);
6594 : : }
6595 : :
6596 : 57 : result->shape = gfc_get_shape (1);
6597 : 57 : gfc_array_size (result, &result->shape[0]);
6598 : :
6599 : 57 : if (array->ts.type == BT_CHARACTER)
6600 : 51 : result->ts.u.cl = array->ts.u.cl;
6601 : :
6602 : : return result;
6603 : : }
6604 : :
6605 : :
6606 : : static gfc_expr *
6607 : 124 : do_xor (gfc_expr *result, gfc_expr *e)
6608 : : {
6609 : 124 : gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
6610 : 124 : gcc_assert (result->ts.type == BT_LOGICAL
6611 : : && result->expr_type == EXPR_CONSTANT);
6612 : :
6613 : 124 : result->value.logical = result->value.logical != e->value.logical;
6614 : 124 : return result;
6615 : : }
6616 : :
6617 : :
6618 : : gfc_expr *
6619 : 992 : gfc_simplify_is_contiguous (gfc_expr *array)
6620 : : {
6621 : 992 : if (gfc_is_simply_contiguous (array, false, true))
6622 : 33 : return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);
6623 : :
6624 : 959 : if (gfc_is_not_contiguous (array))
6625 : 6 : return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
6626 : :
6627 : : return NULL;
6628 : : }
6629 : :
6630 : :
6631 : : gfc_expr *
6632 : 147 : gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
6633 : : {
6634 : 147 : return simplify_transformation (e, dim, NULL, 0, do_xor);
6635 : : }
6636 : :
6637 : :
6638 : : gfc_expr *
6639 : 1064 : gfc_simplify_popcnt (gfc_expr *e)
6640 : : {
6641 : 1064 : int res, k;
6642 : 1064 : mpz_t x;
6643 : :
6644 : 1064 : if (e->expr_type != EXPR_CONSTANT)
6645 : : return NULL;
6646 : :
6647 : 642 : k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6648 : :
6649 : : /* Convert argument to unsigned, then count the '1' bits. */
6650 : 642 : mpz_init_set (x, e->value.integer);
6651 : 642 : convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
6652 : 642 : res = mpz_popcount (x);
6653 : 642 : mpz_clear (x);
6654 : :
6655 : 642 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
6656 : : }
6657 : :
6658 : :
6659 : : gfc_expr *
6660 : 362 : gfc_simplify_poppar (gfc_expr *e)
6661 : : {
6662 : 362 : gfc_expr *popcnt;
6663 : 362 : int i;
6664 : :
6665 : 362 : if (e->expr_type != EXPR_CONSTANT)
6666 : : return NULL;
6667 : :
6668 : 300 : popcnt = gfc_simplify_popcnt (e);
6669 : 300 : gcc_assert (popcnt);
6670 : :
6671 : 300 : bool fail = gfc_extract_int (popcnt, &i);
6672 : 300 : gcc_assert (!fail);
6673 : :
6674 : 300 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
6675 : : }
6676 : :
6677 : :
6678 : : gfc_expr *
6679 : 459 : gfc_simplify_precision (gfc_expr *e)
6680 : : {
6681 : 459 : int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6682 : 459 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
6683 : 459 : gfc_real_kinds[i].precision);
6684 : : }
6685 : :
6686 : :
6687 : : gfc_expr *
6688 : 807 : gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
6689 : : {
6690 : 807 : return simplify_transformation (array, dim, mask, 1, gfc_multiply);
6691 : : }
6692 : :
6693 : :
6694 : : gfc_expr *
6695 : 49 : gfc_simplify_radix (gfc_expr *e)
6696 : : {
6697 : 49 : int i;
6698 : 49 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6699 : :
6700 : 49 : switch (e->ts.type)
6701 : : {
6702 : 0 : case BT_INTEGER:
6703 : 0 : i = gfc_integer_kinds[i].radix;
6704 : 0 : break;
6705 : :
6706 : 49 : case BT_REAL:
6707 : 49 : i = gfc_real_kinds[i].radix;
6708 : 49 : break;
6709 : :
6710 : 0 : default:
6711 : 0 : gcc_unreachable ();
6712 : : }
6713 : :
6714 : 49 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6715 : : }
6716 : :
6717 : :
6718 : : gfc_expr *
6719 : 155 : gfc_simplify_range (gfc_expr *e)
6720 : : {
6721 : 155 : int i;
6722 : 155 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6723 : :
6724 : 155 : switch (e->ts.type)
6725 : : {
6726 : 84 : case BT_INTEGER:
6727 : 84 : i = gfc_integer_kinds[i].range;
6728 : 84 : break;
6729 : :
6730 : 71 : case BT_REAL:
6731 : 71 : case BT_COMPLEX:
6732 : 71 : i = gfc_real_kinds[i].range;
6733 : 71 : break;
6734 : :
6735 : 0 : default:
6736 : 0 : gcc_unreachable ();
6737 : : }
6738 : :
6739 : 155 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6740 : : }
6741 : :
6742 : :
6743 : : gfc_expr *
6744 : 2017 : gfc_simplify_rank (gfc_expr *e)
6745 : : {
6746 : : /* Assumed rank. */
6747 : 2017 : if (e->rank == -1)
6748 : : return NULL;
6749 : :
6750 : 590 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
6751 : : }
6752 : :
6753 : :
6754 : : gfc_expr *
6755 : 27337 : gfc_simplify_real (gfc_expr *e, gfc_expr *k)
6756 : : {
6757 : 27337 : gfc_expr *result = NULL;
6758 : 27337 : int kind, tmp1, tmp2;
6759 : :
6760 : : /* Convert BOZ to real, and return without range checking. */
6761 : 27337 : if (e->ts.type == BT_BOZ)
6762 : : {
6763 : : /* Determine kind for conversion of the BOZ. */
6764 : 85 : if (k)
6765 : 63 : gfc_extract_int (k, &kind);
6766 : : else
6767 : 22 : kind = gfc_default_real_kind;
6768 : :
6769 : 85 : if (!gfc_boz2real (e, kind))
6770 : : return NULL;
6771 : 85 : result = gfc_copy_expr (e);
6772 : 85 : return result;
6773 : : }
6774 : :
6775 : 27252 : if (e->ts.type == BT_COMPLEX)
6776 : 2018 : kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
6777 : : else
6778 : 25234 : kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
6779 : :
6780 : 27252 : if (kind == -1)
6781 : : return &gfc_bad_expr;
6782 : :
6783 : 27252 : if (e->expr_type != EXPR_CONSTANT)
6784 : : return NULL;
6785 : :
6786 : : /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
6787 : : warnings. */
6788 : 21783 : tmp1 = warn_conversion;
6789 : 21783 : tmp2 = warn_conversion_extra;
6790 : 21783 : warn_conversion = warn_conversion_extra = 0;
6791 : :
6792 : 21783 : result = gfc_convert_constant (e, BT_REAL, kind);
6793 : :
6794 : 21783 : warn_conversion = tmp1;
6795 : 21783 : warn_conversion_extra = tmp2;
6796 : :
6797 : 21783 : if (result == &gfc_bad_expr)
6798 : : return &gfc_bad_expr;
6799 : :
6800 : 21782 : return range_check (result, "REAL");
6801 : : }
6802 : :
6803 : :
6804 : : gfc_expr *
6805 : 7 : gfc_simplify_realpart (gfc_expr *e)
6806 : : {
6807 : 7 : gfc_expr *result;
6808 : :
6809 : 7 : if (e->expr_type != EXPR_CONSTANT)
6810 : : return NULL;
6811 : :
6812 : 1 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
6813 : 1 : mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
6814 : :
6815 : 1 : return range_check (result, "REALPART");
6816 : : }
6817 : :
6818 : : gfc_expr *
6819 : 2633 : gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
6820 : : {
6821 : 2633 : gfc_expr *result;
6822 : 2633 : gfc_charlen_t len;
6823 : 2633 : mpz_t ncopies;
6824 : 2633 : bool have_length = false;
6825 : :
6826 : : /* If NCOPIES isn't a constant, there's nothing we can do. */
6827 : 2633 : if (n->expr_type != EXPR_CONSTANT)
6828 : : return NULL;
6829 : :
6830 : : /* If NCOPIES is negative, it's an error. */
6831 : 2075 : if (mpz_sgn (n->value.integer) < 0)
6832 : : {
6833 : 6 : gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6834 : : &n->where);
6835 : 6 : return &gfc_bad_expr;
6836 : : }
6837 : :
6838 : : /* If we don't know the character length, we can do no more. */
6839 : 2069 : if (e->ts.u.cl && e->ts.u.cl->length
6840 : 404 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6841 : : {
6842 : 404 : len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer);
6843 : 404 : have_length = true;
6844 : : }
6845 : 1665 : else if (e->expr_type == EXPR_CONSTANT
6846 : 1665 : && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
6847 : : {
6848 : 1665 : len = e->value.character.length;
6849 : : }
6850 : : else
6851 : : return NULL;
6852 : :
6853 : : /* If the source length is 0, any value of NCOPIES is valid
6854 : : and everything behaves as if NCOPIES == 0. */
6855 : 2069 : mpz_init (ncopies);
6856 : 2069 : if (len == 0)
6857 : 63 : mpz_set_ui (ncopies, 0);
6858 : : else
6859 : 2006 : mpz_set (ncopies, n->value.integer);
6860 : :
6861 : : /* Check that NCOPIES isn't too large. */
6862 : 2069 : if (len)
6863 : : {
6864 : 2006 : mpz_t max, mlen;
6865 : 2006 : int i;
6866 : :
6867 : : /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6868 : 2006 : mpz_init (max);
6869 : 2006 : i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
6870 : :
6871 : 2006 : if (have_length)
6872 : : {
6873 : 347 : mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
6874 : 347 : e->ts.u.cl->length->value.integer);
6875 : : }
6876 : : else
6877 : : {
6878 : 1659 : mpz_init (mlen);
6879 : 1659 : gfc_mpz_set_hwi (mlen, len);
6880 : 1659 : mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
6881 : 1659 : mpz_clear (mlen);
6882 : : }
6883 : :
6884 : : /* The check itself. */
6885 : 2006 : if (mpz_cmp (ncopies, max) > 0)
6886 : : {
6887 : 4 : mpz_clear (max);
6888 : 4 : mpz_clear (ncopies);
6889 : 4 : gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6890 : : &n->where);
6891 : 4 : return &gfc_bad_expr;
6892 : : }
6893 : :
6894 : 2002 : mpz_clear (max);
6895 : : }
6896 : 2065 : mpz_clear (ncopies);
6897 : :
6898 : : /* For further simplification, we need the character string to be
6899 : : constant. */
6900 : 2065 : if (e->expr_type != EXPR_CONSTANT)
6901 : : return NULL;
6902 : :
6903 : 1720 : HOST_WIDE_INT ncop;
6904 : 1720 : if (len ||
6905 : 42 : (e->ts.u.cl->length &&
6906 : 18 : mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
6907 : : {
6908 : 1696 : bool fail = gfc_extract_hwi (n, &ncop);
6909 : 1696 : gcc_assert (!fail);
6910 : : }
6911 : : else
6912 : 24 : ncop = 0;
6913 : :
6914 : 1720 : if (ncop == 0)
6915 : 54 : return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
6916 : :
6917 : 1666 : len = e->value.character.length;
6918 : 1666 : gfc_charlen_t nlen = ncop * len;
6919 : :
6920 : : /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6921 : : (2**28 elements * 4 bytes (wide chars) per element) defer to
6922 : : runtime instead of consuming (unbounded) memory and CPU at
6923 : : compile time. */
6924 : 1666 : if (nlen > 268435456)
6925 : : {
6926 : 1 : gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6927 : : " deferred to runtime, expect bugs", &e->where);
6928 : 1 : return NULL;
6929 : : }
6930 : :
6931 : 1665 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
6932 : 58972 : for (size_t i = 0; i < (size_t) ncop; i++)
6933 : 114944 : for (size_t j = 0; j < (size_t) len; j++)
6934 : 57637 : result->value.character.string[j+i*len]= e->value.character.string[j];
6935 : :
6936 : 1665 : result->value.character.string[nlen] = '\0'; /* For debugger */
6937 : 1665 : return result;
6938 : : }
6939 : :
6940 : :
6941 : : /* This one is a bear, but mainly has to do with shuffling elements. */
6942 : :
6943 : : gfc_expr *
6944 : 5689 : gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
6945 : : gfc_expr *pad, gfc_expr *order_exp)
6946 : : {
6947 : 5689 : int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
6948 : 5689 : int i, rank, npad, x[GFC_MAX_DIMENSIONS];
6949 : 5689 : mpz_t index, size;
6950 : 5689 : unsigned long j;
6951 : 5689 : size_t nsource;
6952 : 5689 : gfc_expr *e, *result;
6953 : 5689 : bool zerosize = false;
6954 : :
6955 : : /* Check that argument expression types are OK. */
6956 : 5689 : if (!is_constant_array_expr (source)
6957 : 4055 : || !is_constant_array_expr (shape_exp)
6958 : 4027 : || !is_constant_array_expr (pad)
6959 : 9716 : || !is_constant_array_expr (order_exp))
6960 : 1674 : return NULL;
6961 : :
6962 : 4015 : if (source->shape == NULL)
6963 : : return NULL;
6964 : :
6965 : : /* Proceed with simplification, unpacking the array. */
6966 : :
6967 : 4012 : mpz_init (index);
6968 : 4012 : rank = 0;
6969 : :
6970 : 68204 : for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
6971 : 60180 : x[i] = 0;
6972 : :
6973 : 21616 : for (;;)
6974 : : {
6975 : 12814 : e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
6976 : 12814 : if (e == NULL)
6977 : : break;
6978 : :
6979 : 8802 : gfc_extract_int (e, &shape[rank]);
6980 : :
6981 : 8802 : gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
6982 : 8802 : if (shape[rank] < 0)
6983 : : {
6984 : 0 : gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
6985 : : "negative value %d for dimension %d",
6986 : : &shape_exp->where, shape[rank], rank+1);
6987 : 0 : mpz_clear (index);
6988 : 0 : return &gfc_bad_expr;
6989 : : }
6990 : :
6991 : 8802 : rank++;
6992 : : }
6993 : :
6994 : 4012 : gcc_assert (rank > 0);
6995 : :
6996 : : /* Now unpack the order array if present. */
6997 : 4012 : if (order_exp == NULL)
6998 : : {
6999 : 12748 : for (i = 0; i < rank; i++)
7000 : 8758 : order[i] = i;
7001 : : }
7002 : : else
7003 : : {
7004 : 22 : mpz_t size;
7005 : 22 : int order_size, shape_size;
7006 : :
7007 : 22 : if (order_exp->rank != shape_exp->rank)
7008 : : {
7009 : 1 : gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
7010 : : &order_exp->where, &shape_exp->where);
7011 : 1 : mpz_clear (index);
7012 : 4 : return &gfc_bad_expr;
7013 : : }
7014 : :
7015 : 21 : gfc_array_size (shape_exp, &size);
7016 : 21 : shape_size = mpz_get_ui (size);
7017 : 21 : mpz_clear (size);
7018 : 21 : gfc_array_size (order_exp, &size);
7019 : 21 : order_size = mpz_get_ui (size);
7020 : 21 : mpz_clear (size);
7021 : 21 : if (order_size != shape_size)
7022 : : {
7023 : 1 : gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
7024 : : &order_exp->where, &shape_exp->where);
7025 : 1 : mpz_clear (index);
7026 : 1 : return &gfc_bad_expr;
7027 : : }
7028 : :
7029 : 58 : for (i = 0; i < rank; i++)
7030 : : {
7031 : 40 : e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
7032 : 40 : gcc_assert (e);
7033 : :
7034 : 40 : gfc_extract_int (e, &order[i]);
7035 : :
7036 : 40 : if (order[i] < 1 || order[i] > rank)
7037 : : {
7038 : 1 : gfc_error ("Element with a value of %d in ORDER at %L must be "
7039 : : "in the range [1, ..., %d] for the RESHAPE intrinsic "
7040 : : "near %L", order[i], &order_exp->where, rank,
7041 : : &shape_exp->where);
7042 : 1 : mpz_clear (index);
7043 : 1 : return &gfc_bad_expr;
7044 : : }
7045 : :
7046 : 39 : order[i]--;
7047 : 39 : if (x[order[i]] != 0)
7048 : : {
7049 : 1 : gfc_error ("ORDER at %L is not a permutation of the size of "
7050 : : "SHAPE at %L", &order_exp->where, &shape_exp->where);
7051 : 1 : mpz_clear (index);
7052 : 1 : return &gfc_bad_expr;
7053 : : }
7054 : 38 : x[order[i]] = 1;
7055 : : }
7056 : : }
7057 : :
7058 : : /* Count the elements in the source and padding arrays. */
7059 : :
7060 : 4008 : npad = 0;
7061 : 4008 : if (pad != NULL)
7062 : : {
7063 : 56 : gfc_array_size (pad, &size);
7064 : 56 : npad = mpz_get_ui (size);
7065 : 56 : mpz_clear (size);
7066 : : }
7067 : :
7068 : 4008 : gfc_array_size (source, &size);
7069 : 4008 : nsource = mpz_get_ui (size);
7070 : 4008 : mpz_clear (size);
7071 : :
7072 : : /* If it weren't for that pesky permutation we could just loop
7073 : : through the source and round out any shortage with pad elements.
7074 : : But no, someone just had to have the compiler do something the
7075 : : user should be doing. */
7076 : :
7077 : 16810 : for (i = 0; i < rank; i++)
7078 : 8794 : x[i] = 0;
7079 : :
7080 : 4008 : result = gfc_get_array_expr (source->ts.type, source->ts.kind,
7081 : : &source->where);
7082 : 4008 : if (source->ts.type == BT_DERIVED)
7083 : 74 : result->ts.u.derived = source->ts.u.derived;
7084 : 4008 : if (source->ts.type == BT_CHARACTER && result->ts.u.cl == NULL)
7085 : 206 : result->ts = source->ts;
7086 : 4008 : result->rank = rank;
7087 : 4008 : result->shape = gfc_get_shape (rank);
7088 : 12802 : for (i = 0; i < rank; i++)
7089 : : {
7090 : 8794 : mpz_init_set_ui (result->shape[i], shape[i]);
7091 : 8794 : if (shape[i] == 0)
7092 : 435 : zerosize = true;
7093 : : }
7094 : :
7095 : 4008 : if (zerosize)
7096 : 423 : goto sizezero;
7097 : :
7098 : 49722 : while (nsource > 0 || npad > 0)
7099 : : {
7100 : : /* Figure out which element to extract. */
7101 : 49722 : mpz_set_ui (index, 0);
7102 : :
7103 : 160824 : for (i = rank - 1; i >= 0; i--)
7104 : : {
7105 : 111102 : mpz_add_ui (index, index, x[order[i]]);
7106 : 111102 : if (i != 0)
7107 : 61380 : mpz_mul_ui (index, index, shape[order[i - 1]]);
7108 : : }
7109 : :
7110 : 49722 : if (mpz_cmp_ui (index, INT_MAX) > 0)
7111 : 0 : gfc_internal_error ("Reshaped array too large at %C");
7112 : :
7113 : 49722 : j = mpz_get_ui (index);
7114 : :
7115 : 49722 : if (j < nsource)
7116 : 49534 : e = gfc_constructor_lookup_expr (source->value.constructor, j);
7117 : : else
7118 : : {
7119 : 188 : if (npad <= 0)
7120 : : {
7121 : 16 : mpz_clear (index);
7122 : 16 : if (pad == NULL)
7123 : 16 : gfc_error ("Without padding, there are not enough elements "
7124 : : "in the intrinsic RESHAPE source at %L to match "
7125 : : "the shape", &source->where);
7126 : 16 : gfc_free_expr (result);
7127 : 16 : return NULL;
7128 : : }
7129 : 172 : j = j - nsource;
7130 : 172 : j = j % npad;
7131 : 172 : e = gfc_constructor_lookup_expr (pad->value.constructor, j);
7132 : : }
7133 : 49706 : gcc_assert (e);
7134 : :
7135 : 49706 : gfc_constructor_append_expr (&result->value.constructor,
7136 : : gfc_copy_expr (e), &e->where);
7137 : :
7138 : : /* Calculate the next element. */
7139 : 49706 : i = 0;
7140 : :
7141 : 63366 : inc:
7142 : 63366 : if (++x[i] < shape[i])
7143 : 46137 : continue;
7144 : 17229 : x[i++] = 0;
7145 : 17229 : if (i < rank)
7146 : 13660 : goto inc;
7147 : :
7148 : : break;
7149 : : }
7150 : :
7151 : 0 : sizezero:
7152 : :
7153 : 3992 : mpz_clear (index);
7154 : :
7155 : 3992 : return result;
7156 : : }
7157 : :
7158 : :
7159 : : gfc_expr *
7160 : 192 : gfc_simplify_rrspacing (gfc_expr *x)
7161 : : {
7162 : 192 : gfc_expr *result;
7163 : 192 : int i;
7164 : 192 : long int e, p;
7165 : :
7166 : 192 : if (x->expr_type != EXPR_CONSTANT)
7167 : : return NULL;
7168 : :
7169 : 60 : i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
7170 : :
7171 : 60 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7172 : :
7173 : : /* RRSPACING(+/- 0.0) = 0.0 */
7174 : 60 : if (mpfr_zero_p (x->value.real))
7175 : : {
7176 : 12 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
7177 : 12 : return result;
7178 : : }
7179 : :
7180 : : /* RRSPACING(inf) = NaN */
7181 : 48 : if (mpfr_inf_p (x->value.real))
7182 : : {
7183 : 12 : mpfr_set_nan (result->value.real);
7184 : 12 : return result;
7185 : : }
7186 : :
7187 : : /* RRSPACING(NaN) = same NaN */
7188 : 36 : if (mpfr_nan_p (x->value.real))
7189 : : {
7190 : 6 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7191 : 6 : return result;
7192 : : }
7193 : :
7194 : : /* | x * 2**(-e) | * 2**p. */
7195 : 30 : mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
7196 : 30 : e = - (long int) mpfr_get_exp (x->value.real);
7197 : 30 : mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
7198 : :
7199 : 30 : p = (long int) gfc_real_kinds[i].digits;
7200 : 30 : mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
7201 : :
7202 : 30 : return range_check (result, "RRSPACING");
7203 : : }
7204 : :
7205 : :
7206 : : gfc_expr *
7207 : 168 : gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
7208 : : {
7209 : 168 : int k, neg_flag, power, exp_range;
7210 : 168 : mpfr_t scale, radix;
7211 : 168 : gfc_expr *result;
7212 : :
7213 : 168 : if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
7214 : : return NULL;
7215 : :
7216 : 12 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7217 : :
7218 : 12 : if (mpfr_zero_p (x->value.real))
7219 : : {
7220 : 0 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
7221 : 0 : return result;
7222 : : }
7223 : :
7224 : 12 : k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
7225 : :
7226 : 12 : exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
7227 : :
7228 : : /* This check filters out values of i that would overflow an int. */
7229 : 12 : if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
7230 : 12 : || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
7231 : : {
7232 : 0 : gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
7233 : 0 : gfc_free_expr (result);
7234 : 0 : return &gfc_bad_expr;
7235 : : }
7236 : :
7237 : : /* Compute scale = radix ** power. */
7238 : 12 : power = mpz_get_si (i->value.integer);
7239 : :
7240 : 12 : if (power >= 0)
7241 : : neg_flag = 0;
7242 : : else
7243 : : {
7244 : 0 : neg_flag = 1;
7245 : 0 : power = -power;
7246 : : }
7247 : :
7248 : 12 : gfc_set_model_kind (x->ts.kind);
7249 : 12 : mpfr_init (scale);
7250 : 12 : mpfr_init (radix);
7251 : 12 : mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
7252 : 12 : mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
7253 : :
7254 : 12 : if (neg_flag)
7255 : 0 : mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
7256 : : else
7257 : 12 : mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
7258 : :
7259 : 12 : mpfr_clears (scale, radix, NULL);
7260 : :
7261 : 12 : return range_check (result, "SCALE");
7262 : : }
7263 : :
7264 : :
7265 : : /* Variants of strspn and strcspn that operate on wide characters. */
7266 : :
7267 : : static size_t
7268 : 60 : wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
7269 : : {
7270 : 60 : size_t i = 0;
7271 : 60 : const gfc_char_t *c;
7272 : :
7273 : 144 : while (s1[i])
7274 : : {
7275 : 354 : for (c = s2; *c; c++)
7276 : : {
7277 : 294 : if (s1[i] == *c)
7278 : : break;
7279 : : }
7280 : 144 : if (*c == '\0')
7281 : : break;
7282 : 84 : i++;
7283 : : }
7284 : :
7285 : 60 : return i;
7286 : : }
7287 : :
7288 : : static size_t
7289 : 60 : wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
7290 : : {
7291 : 60 : size_t i = 0;
7292 : 60 : const gfc_char_t *c;
7293 : :
7294 : 396 : while (s1[i])
7295 : : {
7296 : 1392 : for (c = s2; *c; c++)
7297 : : {
7298 : 1056 : if (s1[i] == *c)
7299 : : break;
7300 : : }
7301 : 384 : if (*c)
7302 : : break;
7303 : 336 : i++;
7304 : : }
7305 : :
7306 : 60 : return i;
7307 : : }
7308 : :
7309 : :
7310 : : gfc_expr *
7311 : 958 : gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
7312 : : {
7313 : 958 : gfc_expr *result;
7314 : 958 : int back;
7315 : 958 : size_t i;
7316 : 958 : size_t indx, len, lenc;
7317 : 958 : int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
7318 : :
7319 : 958 : if (k == -1)
7320 : : return &gfc_bad_expr;
7321 : :
7322 : 958 : if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
7323 : 182 : || ( b != NULL && b->expr_type != EXPR_CONSTANT))
7324 : : return NULL;
7325 : :
7326 : 144 : if (b != NULL && b->value.logical != 0)
7327 : : back = 1;
7328 : : else
7329 : 72 : back = 0;
7330 : :
7331 : 144 : len = e->value.character.length;
7332 : 144 : lenc = c->value.character.length;
7333 : :
7334 : 144 : if (len == 0 || lenc == 0)
7335 : : {
7336 : : indx = 0;
7337 : : }
7338 : : else
7339 : : {
7340 : 120 : if (back == 0)
7341 : : {
7342 : 60 : indx = wide_strcspn (e->value.character.string,
7343 : 60 : c->value.character.string) + 1;
7344 : 60 : if (indx > len)
7345 : 48 : indx = 0;
7346 : : }
7347 : : else
7348 : 408 : for (indx = len; indx > 0; indx--)
7349 : : {
7350 : 1488 : for (i = 0; i < lenc; i++)
7351 : : {
7352 : 1140 : if (c->value.character.string[i]
7353 : 1140 : == e->value.character.string[indx - 1])
7354 : : break;
7355 : : }
7356 : 396 : if (i < lenc)
7357 : : break;
7358 : : }
7359 : : }
7360 : :
7361 : 144 : result = gfc_get_int_expr (k, &e->where, indx);
7362 : 144 : return range_check (result, "SCAN");
7363 : : }
7364 : :
7365 : :
7366 : : gfc_expr *
7367 : 252 : gfc_simplify_selected_char_kind (gfc_expr *e)
7368 : : {
7369 : 252 : int kind;
7370 : :
7371 : 252 : if (e->expr_type != EXPR_CONSTANT)
7372 : : return NULL;
7373 : :
7374 : 167 : if (gfc_compare_with_Cstring (e, "ascii", false) == 0
7375 : 167 : || gfc_compare_with_Cstring (e, "default", false) == 0)
7376 : : kind = 1;
7377 : 83 : else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
7378 : : kind = 4;
7379 : : else
7380 : 39 : kind = -1;
7381 : :
7382 : 167 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
7383 : : }
7384 : :
7385 : :
7386 : : gfc_expr *
7387 : 252 : gfc_simplify_selected_int_kind (gfc_expr *e)
7388 : : {
7389 : 252 : int i, kind, range;
7390 : :
7391 : 252 : if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
7392 : 49 : return NULL;
7393 : :
7394 : : kind = INT_MAX;
7395 : :
7396 : 1218 : for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
7397 : 1015 : if (gfc_integer_kinds[i].range >= range
7398 : 526 : && gfc_integer_kinds[i].kind < kind)
7399 : 1015 : kind = gfc_integer_kinds[i].kind;
7400 : :
7401 : 203 : if (kind == INT_MAX)
7402 : 0 : kind = -1;
7403 : :
7404 : 203 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
7405 : : }
7406 : :
7407 : :
7408 : : gfc_expr *
7409 : 78 : gfc_simplify_selected_logical_kind (gfc_expr *e)
7410 : : {
7411 : 78 : int i, kind, bits;
7412 : :
7413 : 78 : if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &bits))
7414 : 12 : return NULL;
7415 : :
7416 : : kind = INT_MAX;
7417 : :
7418 : 396 : for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
7419 : 330 : if (gfc_logical_kinds[i].bit_size >= bits
7420 : 180 : && gfc_logical_kinds[i].kind < kind)
7421 : 330 : kind = gfc_logical_kinds[i].kind;
7422 : :
7423 : 66 : if (kind == INT_MAX)
7424 : 6 : kind = -1;
7425 : :
7426 : 66 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
7427 : : }
7428 : :
7429 : :
7430 : : gfc_expr *
7431 : 992 : gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
7432 : : {
7433 : 992 : int range, precision, radix, i, kind, found_precision, found_range,
7434 : : found_radix;
7435 : 992 : locus *loc = &gfc_current_locus;
7436 : :
7437 : 992 : if (p == NULL)
7438 : 60 : precision = 0;
7439 : : else
7440 : : {
7441 : 932 : if (p->expr_type != EXPR_CONSTANT
7442 : 932 : || gfc_extract_int (p, &precision))
7443 : 46 : return NULL;
7444 : 886 : loc = &p->where;
7445 : : }
7446 : :
7447 : 946 : if (q == NULL)
7448 : 681 : range = 0;
7449 : : else
7450 : : {
7451 : 265 : if (q->expr_type != EXPR_CONSTANT
7452 : 265 : || gfc_extract_int (q, &range))
7453 : 54 : return NULL;
7454 : :
7455 : : if (!loc)
7456 : : loc = &q->where;
7457 : : }
7458 : :
7459 : 892 : if (rdx == NULL)
7460 : 832 : radix = 0;
7461 : : else
7462 : : {
7463 : 60 : if (rdx->expr_type != EXPR_CONSTANT
7464 : 60 : || gfc_extract_int (rdx, &radix))
7465 : 24 : return NULL;
7466 : :
7467 : : if (!loc)
7468 : : loc = &rdx->where;
7469 : : }
7470 : :
7471 : 868 : kind = INT_MAX;
7472 : 868 : found_precision = 0;
7473 : 868 : found_range = 0;
7474 : 868 : found_radix = 0;
7475 : :
7476 : 4340 : for (i = 0; gfc_real_kinds[i].kind != 0; i++)
7477 : : {
7478 : 3472 : if (gfc_real_kinds[i].precision >= precision)
7479 : 2352 : found_precision = 1;
7480 : :
7481 : 3472 : if (gfc_real_kinds[i].range >= range)
7482 : 3350 : found_range = 1;
7483 : :
7484 : 3472 : if (radix == 0 || gfc_real_kinds[i].radix == radix)
7485 : 3448 : found_radix = 1;
7486 : :
7487 : 3472 : if (gfc_real_kinds[i].precision >= precision
7488 : 2352 : && gfc_real_kinds[i].range >= range
7489 : 2352 : && (radix == 0 || gfc_real_kinds[i].radix == radix)
7490 : 2328 : && gfc_real_kinds[i].kind < kind)
7491 : 3472 : kind = gfc_real_kinds[i].kind;
7492 : : }
7493 : :
7494 : 868 : if (kind == INT_MAX)
7495 : : {
7496 : 12 : if (found_radix && found_range && !found_precision)
7497 : : kind = -1;
7498 : 6 : else if (found_radix && found_precision && !found_range)
7499 : : kind = -2;
7500 : 6 : else if (found_radix && !found_precision && !found_range)
7501 : : kind = -3;
7502 : 6 : else if (found_radix)
7503 : : kind = -4;
7504 : : else
7505 : 6 : kind = -5;
7506 : : }
7507 : :
7508 : 868 : return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
7509 : : }
7510 : :
7511 : :
7512 : : gfc_expr *
7513 : 770 : gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
7514 : : {
7515 : 770 : gfc_expr *result;
7516 : 770 : mpfr_t exp, absv, log2, pow2, frac;
7517 : 770 : long exp2;
7518 : :
7519 : 770 : if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
7520 : : return NULL;
7521 : :
7522 : 150 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7523 : :
7524 : : /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7525 : : SET_EXPONENT (NaN) = same NaN */
7526 : 150 : if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real))
7527 : : {
7528 : 18 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7529 : 18 : return result;
7530 : : }
7531 : :
7532 : : /* SET_EXPONENT (inf) = NaN */
7533 : 132 : if (mpfr_inf_p (x->value.real))
7534 : : {
7535 : 12 : mpfr_set_nan (result->value.real);
7536 : 12 : return result;
7537 : : }
7538 : :
7539 : 120 : gfc_set_model_kind (x->ts.kind);
7540 : 120 : mpfr_init (absv);
7541 : 120 : mpfr_init (log2);
7542 : 120 : mpfr_init (exp);
7543 : 120 : mpfr_init (pow2);
7544 : 120 : mpfr_init (frac);
7545 : :
7546 : 120 : mpfr_abs (absv, x->value.real, GFC_RND_MODE);
7547 : 120 : mpfr_log2 (log2, absv, GFC_RND_MODE);
7548 : :
7549 : 120 : mpfr_floor (log2, log2);
7550 : 120 : mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
7551 : :
7552 : : /* Old exponent value, and fraction. */
7553 : 120 : mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
7554 : :
7555 : 120 : mpfr_div (frac, x->value.real, pow2, GFC_RND_MODE);
7556 : :
7557 : : /* New exponent. */
7558 : 120 : exp2 = mpz_get_si (i->value.integer);
7559 : 120 : mpfr_mul_2si (result->value.real, frac, exp2, GFC_RND_MODE);
7560 : :
7561 : 120 : mpfr_clears (absv, log2, exp, pow2, frac, NULL);
7562 : :
7563 : 120 : return range_check (result, "SET_EXPONENT");
7564 : : }
7565 : :
7566 : :
7567 : : gfc_expr *
7568 : 5322 : gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
7569 : : {
7570 : 5322 : mpz_t shape[GFC_MAX_DIMENSIONS];
7571 : 5322 : gfc_expr *result, *e, *f;
7572 : 5322 : gfc_array_ref *ar;
7573 : 5322 : int n;
7574 : 5322 : bool t;
7575 : 5322 : int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
7576 : :
7577 : 5322 : if (source->rank == -1)
7578 : : return NULL;
7579 : :
7580 : 4446 : result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
7581 : 4446 : result->shape = gfc_get_shape (1);
7582 : 4446 : mpz_init (result->shape[0]);
7583 : :
7584 : 4446 : if (source->rank == 0)
7585 : : return result;
7586 : :
7587 : 4395 : if (source->expr_type == EXPR_VARIABLE)
7588 : : {
7589 : 4363 : ar = gfc_find_array_ref (source);
7590 : 4363 : t = gfc_array_ref_shape (ar, shape);
7591 : : }
7592 : 32 : else if (source->shape)
7593 : : {
7594 : 37 : t = true;
7595 : 37 : for (n = 0; n < source->rank; n++)
7596 : : {
7597 : 24 : mpz_init (shape[n]);
7598 : 24 : mpz_set (shape[n], source->shape[n]);
7599 : : }
7600 : : }
7601 : : else
7602 : : t = false;
7603 : :
7604 : 7563 : for (n = 0; n < source->rank; n++)
7605 : : {
7606 : 6278 : e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
7607 : :
7608 : 6278 : if (t)
7609 : 3154 : mpz_set (e->value.integer, shape[n]);
7610 : : else
7611 : : {
7612 : 3124 : mpz_set_ui (e->value.integer, n + 1);
7613 : :
7614 : 3124 : f = simplify_size (source, e, k);
7615 : 3124 : gfc_free_expr (e);
7616 : 3124 : if (f == NULL)
7617 : : {
7618 : 3109 : gfc_free_expr (result);
7619 : 3109 : return NULL;
7620 : : }
7621 : : else
7622 : : e = f;
7623 : : }
7624 : :
7625 : 3169 : if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
7626 : : {
7627 : 1 : gfc_free_expr (result);
7628 : 1 : if (t)
7629 : 1 : gfc_clear_shape (shape, source->rank);
7630 : 1 : return &gfc_bad_expr;
7631 : : }
7632 : :
7633 : 3168 : gfc_constructor_append_expr (&result->value.constructor, e, NULL);
7634 : : }
7635 : :
7636 : 1285 : if (t)
7637 : 1285 : gfc_clear_shape (shape, source->rank);
7638 : :
7639 : 1285 : mpz_set_si (result->shape[0], source->rank);
7640 : :
7641 : 1285 : return result;
7642 : : }
7643 : :
7644 : :
7645 : : static gfc_expr *
7646 : 34122 : simplify_size (gfc_expr *array, gfc_expr *dim, int k)
7647 : : {
7648 : 34122 : mpz_t size;
7649 : 34122 : gfc_expr *return_value;
7650 : 34122 : int d;
7651 : 34122 : gfc_ref *ref;
7652 : :
7653 : : /* For unary operations, the size of the result is given by the size
7654 : : of the operand. For binary ones, it's the size of the first operand
7655 : : unless it is scalar, then it is the size of the second. */
7656 : 34122 : if (array->expr_type == EXPR_OP && !array->value.op.uop)
7657 : : {
7658 : 44 : gfc_expr* replacement;
7659 : 44 : gfc_expr* simplified;
7660 : :
7661 : 44 : switch (array->value.op.op)
7662 : : {
7663 : : /* Unary operations. */
7664 : 7 : case INTRINSIC_NOT:
7665 : 7 : case INTRINSIC_UPLUS:
7666 : 7 : case INTRINSIC_UMINUS:
7667 : 7 : case INTRINSIC_PARENTHESES:
7668 : 7 : replacement = array->value.op.op1;
7669 : 7 : break;
7670 : :
7671 : : /* Binary operations. If any one of the operands is scalar, take
7672 : : the other one's size. If both of them are arrays, it does not
7673 : : matter -- try to find one with known shape, if possible. */
7674 : 37 : default:
7675 : 37 : if (array->value.op.op1->rank == 0)
7676 : 25 : replacement = array->value.op.op2;
7677 : 12 : else if (array->value.op.op2->rank == 0)
7678 : : replacement = array->value.op.op1;
7679 : : else
7680 : : {
7681 : 0 : simplified = simplify_size (array->value.op.op1, dim, k);
7682 : 0 : if (simplified)
7683 : : return simplified;
7684 : :
7685 : 0 : replacement = array->value.op.op2;
7686 : : }
7687 : : break;
7688 : : }
7689 : :
7690 : : /* Try to reduce it directly if possible. */
7691 : 44 : simplified = simplify_size (replacement, dim, k);
7692 : :
7693 : : /* Otherwise, we build a new SIZE call. This is hopefully at least
7694 : : simpler than the original one. */
7695 : 44 : if (!simplified)
7696 : : {
7697 : 20 : gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
7698 : 20 : simplified = gfc_build_intrinsic_call (gfc_current_ns,
7699 : : GFC_ISYM_SIZE, "size",
7700 : : array->where, 3,
7701 : : gfc_copy_expr (replacement),
7702 : : gfc_copy_expr (dim),
7703 : : kind);
7704 : : }
7705 : 44 : return simplified;
7706 : : }
7707 : :
7708 : 68937 : for (ref = array->ref; ref; ref = ref->next)
7709 : 32251 : if (ref->type == REF_ARRAY && ref->u.ar.as
7710 : 67114 : && !gfc_resolve_array_spec (ref->u.ar.as, 0))
7711 : : return NULL;
7712 : :
7713 : 34074 : if (dim == NULL)
7714 : : {
7715 : 15235 : if (!gfc_array_size (array, &size))
7716 : : return NULL;
7717 : : }
7718 : : else
7719 : : {
7720 : 18839 : if (dim->expr_type != EXPR_CONSTANT)
7721 : : return NULL;
7722 : :
7723 : 18505 : if (array->rank == -1)
7724 : : return NULL;
7725 : :
7726 : 17863 : d = mpz_get_si (dim->value.integer) - 1;
7727 : 17863 : if (d < 0 || d > array->rank - 1)
7728 : : {
7729 : 6 : gfc_error ("DIM argument (%d) to intrinsic SIZE at %L out of range "
7730 : : "(1:%d)", d+1, &array->where, array->rank);
7731 : 6 : return &gfc_bad_expr;
7732 : : }
7733 : :
7734 : 17857 : if (!gfc_array_dimen_size (array, d, &size))
7735 : : return NULL;
7736 : : }
7737 : :
7738 : 4848 : return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
7739 : 4848 : mpz_set (return_value->value.integer, size);
7740 : 4848 : mpz_clear (size);
7741 : :
7742 : 4848 : return return_value;
7743 : : }
7744 : :
7745 : :
7746 : : gfc_expr *
7747 : 30172 : gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
7748 : : {
7749 : 30172 : gfc_expr *result;
7750 : 30172 : int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
7751 : :
7752 : 30172 : if (k == -1)
7753 : : return &gfc_bad_expr;
7754 : :
7755 : 30172 : result = simplify_size (array, dim, k);
|
