Branch data Line data Source code
1 : : /* Simplify intrinsic functions at compile-time.
2 : : Copyright (C) 2000-2023 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 : 331716 : range_check (gfc_expr *result, const char *name)
79 : : {
80 : 331716 : if (result == NULL)
81 : : return &gfc_bad_expr;
82 : :
83 : 331716 : if (result->expr_type != EXPR_CONSTANT)
84 : : return result;
85 : :
86 : 331696 : 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 : 128690 : get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
121 : : {
122 : 128690 : int kind;
123 : :
124 : 128690 : if (k == NULL)
125 : : return default_kind;
126 : :
127 : 29656 : 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 : 29656 : if (gfc_extract_int (k, &kind)
135 : 29656 : || 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 : 29656 : 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 : 88521 : is_constant_array_expr (gfc_expr *e)
221 : : {
222 : 88521 : gfc_constructor *c;
223 : 88521 : bool array_OK = true;
224 : 88521 : mpz_t size;
225 : :
226 : 88521 : if (e == NULL)
227 : : return true;
228 : :
229 : 81306 : if (e->expr_type == EXPR_VARIABLE && e->rank > 0
230 : 29761 : && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
231 : 988 : gfc_simplify_expr (e, 1);
232 : :
233 : 81306 : if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
234 : 63748 : return false;
235 : :
236 : : /* A non-zero-sized constant array shall have a non-empty constructor. */
237 : 17558 : if (e->rank > 0 && e->shape != NULL && e->value.constructor == NULL)
238 : : {
239 : 343 : mpz_init_set_ui (size, 1);
240 : 896 : for (int j = 0; j < e->rank; j++)
241 : 553 : mpz_mul (size, size, e->shape[j]);
242 : 343 : bool not_size0 = (mpz_cmp_si (size, 0) != 0);
243 : 343 : mpz_clear (size);
244 : 343 : if (not_size0)
245 : : return false;
246 : : }
247 : :
248 : 17555 : for (c = gfc_constructor_first (e->value.constructor);
249 : 360865 : c; c = gfc_constructor_next (c))
250 : 343333 : 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 : 17555 : bool expand;
260 : 35110 : expand = (e->rank == 1
261 : 16829 : && e->shape
262 : 34377 : && (mpz_cmp_ui (e->shape[0], flag_max_array_constructor) < 0));
263 : :
264 : 17555 : 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 : 6337 : gfc_is_constant_array_expr (gfc_expr *e)
296 : : {
297 : 6337 : return is_constant_array_expr (e);
298 : : }
299 : :
300 : :
301 : : /* Test for a size zero array. */
302 : : bool
303 : 128174 : gfc_is_size_zero_array (gfc_expr *array)
304 : : {
305 : :
306 : 128174 : if (array->rank == 0)
307 : : return false;
308 : :
309 : 124763 : if (array->expr_type == EXPR_VARIABLE && array->rank > 0
310 : 16545 : && array->symtree->n.sym->attr.flavor == FL_PARAMETER
311 : 6481 : && array->shape != NULL)
312 : : {
313 : 13260 : for (int i = 0; i < array->rank; i++)
314 : 7886 : if (mpz_cmp_si (array->shape[i], 0) <= 0)
315 : : return true;
316 : :
317 : : return false;
318 : : }
319 : :
320 : 118530 : if (array->expr_type == EXPR_ARRAY)
321 : 75252 : 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 : 3243 : init_result_expr (gfc_expr *e, int init, gfc_expr *array)
331 : : {
332 : 3243 : 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 : 3114 : else if (e && e->expr_type == EXPR_CONSTANT)
342 : : {
343 : 3114 : int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
344 : 3114 : HOST_WIDE_INT length;
345 : 3114 : gfc_char_t *string;
346 : :
347 : 3114 : switch (e->ts.type)
348 : : {
349 : 1954 : case BT_LOGICAL:
350 : 1954 : e->value.logical = (init ? 1 : 0);
351 : 1954 : 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 : 279 : case BT_REAL:
363 : 279 : 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 : 253 : else if (init == INT_MAX)
369 : 26 : 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 : 3114 : }
408 : : else
409 : 0 : gcc_unreachable();
410 : 3243 : }
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 : 2739 : transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
476 : : int kind, locus* where)
477 : : {
478 : 2739 : gfc_expr *result;
479 : 2739 : int i, nelem;
480 : :
481 : 2739 : if (!dim || array->rank == 1)
482 : 2610 : 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 : 2272 : simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
541 : : transformational_op op)
542 : : {
543 : 2272 : gfc_expr *a, *m;
544 : 2272 : gfc_constructor *array_ctor, *mask_ctor;
545 : :
546 : : /* Shortcut for constant .FALSE. MASK. */
547 : 2272 : if (mask
548 : 98 : && mask->expr_type == EXPR_CONSTANT
549 : 24 : && !mask->value.logical)
550 : : return result;
551 : :
552 : 2248 : array_ctor = gfc_constructor_first (array->value.constructor);
553 : 2248 : mask_ctor = NULL;
554 : 2248 : if (mask && mask->expr_type == EXPR_ARRAY)
555 : 74 : mask_ctor = gfc_constructor_first (mask->value.constructor);
556 : :
557 : 69872 : while (array_ctor)
558 : : {
559 : 67624 : a = array_ctor->expr;
560 : 67624 : array_ctor = gfc_constructor_next (array_ctor);
561 : :
562 : : /* A constant MASK equals .TRUE. here and can be ignored. */
563 : 67624 : 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 : 67320 : result = op (result, gfc_copy_expr (a));
572 : 67320 : 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 : 45588 : simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
729 : : int init_val, transformational_op op)
730 : : {
731 : 45588 : gfc_expr *result;
732 : 45588 : bool size_zero;
733 : :
734 : 45588 : size_zero = gfc_is_size_zero_array (array);
735 : :
736 : 88486 : if (!(is_constant_array_expr (array) || size_zero)
737 : 2690 : || array->shape == NULL
738 : 48275 : || !gfc_is_constant_expr (dim))
739 : 42901 : return NULL;
740 : :
741 : 2687 : if (mask
742 : 242 : && !is_constant_array_expr (mask)
743 : 2869 : && mask->expr_type != EXPR_CONSTANT)
744 : : return NULL;
745 : :
746 : 2529 : result = transformational_result (array, dim, array->ts.type,
747 : : array->ts.kind, &array->where);
748 : 2529 : init_result_expr (result, init_val, array);
749 : :
750 : 2529 : if (size_zero)
751 : : return result;
752 : :
753 : 2294 : return !dim || array->rank == 1 ?
754 : 2211 : 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 : 24464 : gfc_simplify_abs (gfc_expr *e)
763 : : {
764 : 24464 : gfc_expr *result;
765 : :
766 : 24464 : 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 : 19898 : simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
795 : : {
796 : 19898 : gfc_expr *result;
797 : 19898 : int kind;
798 : 19898 : bool too_large = false;
799 : :
800 : 19898 : if (e->expr_type != EXPR_CONSTANT)
801 : : return NULL;
802 : :
803 : 12938 : kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
804 : 12938 : if (kind == -1)
805 : : return &gfc_bad_expr;
806 : :
807 : 12938 : 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 : 12930 : 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 : 12930 : if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
820 : : too_large = true;
821 : 12921 : else if (kind == 4)
822 : : {
823 : 1384 : mpz_t t;
824 : 1384 : mpz_init_set_ui (t, 2);
825 : 1384 : mpz_pow_ui (t, t, 32);
826 : 1384 : mpz_sub_ui (t, t, 1);
827 : 1384 : if (mpz_cmp (e->value.integer, t) > 0)
828 : 2 : too_large = true;
829 : 1384 : mpz_clear (t);
830 : : }
831 : :
832 : 1384 : 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 : 12919 : result = gfc_get_character_expr (kind, &e->where, NULL, 1);
840 : 12919 : result->value.character.string[0] = mpz_get_ui (e->value.integer);
841 : :
842 : 12919 : 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 : 1152 : gfc_simplify_adjustl (gfc_expr *e)
927 : : {
928 : 1152 : gfc_expr *result;
929 : 1152 : int count, i, len;
930 : 1152 : gfc_char_t ch;
931 : :
932 : 1152 : 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 : 1702 : gfc_simplify_aimag (gfc_expr *e)
986 : : {
987 : 1702 : gfc_expr *result;
988 : :
989 : 1702 : 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 : 1309 : gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
1025 : : {
1026 : 1309 : 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 : 32189 : gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
1114 : : {
1115 : 32189 : 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 : 3619 : gfc_simplify_bit_size (gfc_expr *e)
1659 : : {
1660 : 3619 : int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
1661 : 3619 : return gfc_get_int_expr (e->ts.kind, &e->where,
1662 : 3619 : 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 : 6840 : gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1780 : : {
1781 : 6840 : 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 : 6672 : simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1789 : : {
1790 : 6672 : gfc_expr *result;
1791 : :
1792 : 6672 : if (x->expr_type != EXPR_CONSTANT
1793 : 5205 : || (y != NULL && y->expr_type != EXPR_CONSTANT))
1794 : : return NULL;
1795 : :
1796 : 5095 : result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
1797 : :
1798 : 5095 : switch (x->ts.type)
1799 : : {
1800 : 3604 : case BT_INTEGER:
1801 : 3604 : mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
1802 : 3604 : break;
1803 : :
1804 : 1491 : case BT_REAL:
1805 : 1491 : mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
1806 : 1491 : 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 : 5095 : if (!y)
1817 : 224 : return range_check (result, name);
1818 : :
1819 : 4871 : switch (y->ts.type)
1820 : : {
1821 : 3504 : case BT_INTEGER:
1822 : 3504 : mpfr_set_z (mpc_imagref (result->value.complex),
1823 : 3504 : y->value.integer, GFC_RND_MODE);
1824 : 3504 : break;
1825 : :
1826 : 1367 : case BT_REAL:
1827 : 1367 : mpfr_set (mpc_imagref (result->value.complex),
1828 : : y->value.real, GFC_RND_MODE);
1829 : 1367 : break;
1830 : :
1831 : 0 : default:
1832 : 0 : gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
1833 : : }
1834 : :
1835 : 4871 : return range_check (result, name);
1836 : : }
1837 : :
1838 : :
1839 : : gfc_expr *
1840 : 6318 : gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1841 : : {
1842 : 6318 : int kind;
1843 : :
1844 : 6318 : kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
1845 : 6318 : if (kind == -1)
1846 : : return &gfc_bad_expr;
1847 : :
1848 : 6318 : 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 : 920 : gfc_simplify_cos (gfc_expr *x)
1914 : : {
1915 : 920 : gfc_expr *result;
1916 : :
1917 : 920 : 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 : 410 : gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
2066 : : {
2067 : 410 : gfc_expr *result;
2068 : 410 : bool size_zero;
2069 : :
2070 : 410 : size_zero = gfc_is_size_zero_array (mask);
2071 : :
2072 : 765 : if (!(is_constant_array_expr (mask) || size_zero)
2073 : 55 : || !gfc_is_constant_expr (dim)
2074 : 465 : || !gfc_is_constant_expr (kind))
2075 : 355 : 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 : 3623 : gfc_simplify_epsilon (gfc_expr *e)
2941 : : {
2942 : 3623 : gfc_expr *result;
2943 : 3623 : int i;
2944 : :
2945 : 3623 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2946 : :
2947 : 3623 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
2948 : 3623 : mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
2949 : :
2950 : 3623 : return range_check (result, "EPSILON");
2951 : : }
2952 : :
2953 : :
2954 : : gfc_expr *
2955 : 1206 : gfc_simplify_exp (gfc_expr *x)
2956 : : {
2957 : 1206 : gfc_expr *result;
2958 : :
2959 : 1206 : if (x->expr_type != EXPR_CONSTANT)
2960 : : return NULL;
2961 : :
2962 : 139 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2963 : :
2964 : 139 : 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 : 57 : case BT_COMPLEX:
2971 : 57 : gfc_set_model_kind (x->ts.kind);
2972 : 57 : mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
2973 : 57 : break;
2974 : :
2975 : 0 : default:
2976 : 0 : gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2977 : : }
2978 : :
2979 : 139 : 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 : 5461 : gfc_simplify_huge (gfc_expr *e)
3253 : : {
3254 : 5461 : gfc_expr *result;
3255 : 5461 : int i;
3256 : :
3257 : 5461 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3258 : 5461 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3259 : :
3260 : 5461 : switch (e->ts.type)
3261 : : {
3262 : 4177 : case BT_INTEGER:
3263 : 4177 : mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
3264 : 4177 : break;
3265 : :
3266 : 1284 : case BT_REAL:
3267 : 1284 : mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
3268 : 1284 : break;
3269 : :
3270 : 0 : default:
3271 : 0 : gcc_unreachable ();
3272 : : }
3273 : :
3274 : 5461 : 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 : 157 : gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3342 : : {
3343 : 157 : 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 : 109 : gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3361 : : {
3362 : 109 : 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 : 3460 : gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
3518 : : {
3519 : 3460 : gfc_expr *result;
3520 : 3460 : gfc_char_t index;
3521 : 3460 : int k;
3522 : :
3523 : 3460 : 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 : 6155 : simplify_intconv (gfc_expr *e, int kind, const char *name)
3633 : : {
3634 : 6155 : gfc_expr *result = NULL;
3635 : 6155 : int tmp1, tmp2;
3636 : :
3637 : : /* Convert BOZ to integer, and return without range checking. */
3638 : 6155 : if (e->ts.type == BT_BOZ)
3639 : : {
3640 : 1472 : if (!gfc_boz2int (e, kind))
3641 : : return NULL;
3642 : 1472 : result = gfc_copy_expr (e);
3643 : 1472 : return result;
3644 : : }
3645 : :
3646 : 4683 : if (e->expr_type != EXPR_CONSTANT)
3647 : : return NULL;
3648 : :
3649 : : /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
3650 : : warnings. */
3651 : 1030 : tmp1 = warn_conversion;
3652 : 1030 : tmp2 = warn_conversion_extra;
3653 : 1030 : warn_conversion = warn_conversion_extra = 0;
3654 : :
3655 : 1030 : result = gfc_convert_constant (e, BT_INTEGER, kind);
3656 : :
3657 : 1030 : warn_conversion = tmp1;
3658 : 1030 : warn_conversion_extra = tmp2;
3659 : :
3660 : 1030 : if (result == &gfc_bad_expr)
3661 : : return &gfc_bad_expr;
3662 : :
3663 : 1030 : return range_check (result, name);
3664 : : }
3665 : :
3666 : :
3667 : : gfc_expr *
3668 : 6052 : gfc_simplify_int (gfc_expr *e, gfc_expr *k)
3669 : : {
3670 : 6052 : int kind;
3671 : :
3672 : 6052 : kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
3673 : 6052 : if (kind == -1)
3674 : : return &gfc_bad_expr;
3675 : :
3676 : 6052 : 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 : 1348 : gfc_simplify_ifix (gfc_expr *e)
3702 : : {
3703 : 1348 : gfc_expr *rtrunc, *result;
3704 : :
3705 : 1348 : 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 : 673 : gfc_simplify_idint (gfc_expr *e)
3723 : : {
3724 : 673 : gfc_expr *rtrunc, *result;
3725 : :
3726 : 673 : 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 : 109 : gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3771 : : {
3772 : 109 : 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 : 1665 : gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
3954 : : {
3955 : 1665 : gfc_expr *result;
3956 : 1665 : int shift, ashift, isize, ssize, delta, k;
3957 : 1665 : int i, *bits;
3958 : :
3959 : 1665 : 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 : 4446 : gfc_simplify_kind (gfc_expr *e)
4058 : : {
4059 : 4446 : return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
4060 : : }
4061 : :
4062 : :
4063 : : static gfc_expr *
4064 : 13177 : 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 : 13177 : gfc_expr *l, *u, *result;
4068 : 13177 : int k;
4069 : :
4070 : 22233 : k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4071 : : gfc_default_integer_kind);
4072 : 13177 : if (k == -1)
4073 : : return &gfc_bad_expr;
4074 : :
4075 : 13177 : 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 : 13177 : 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 : 11763 : gcc_assert (array->expr_type == EXPR_VARIABLE);
4099 : 11763 : gcc_assert (as);
4100 : :
4101 : 11763 : if (!gfc_resolve_array_spec (as, 0))
4102 : : return NULL;
4103 : :
4104 : : /* The last dimension of an assumed-size array is special. */
4105 : 11760 : if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
4106 : 1170 : || (coarray && d == as->rank + as->corank
4107 : 424 : && (!upper || flag_coarray == GFC_FCOARRAY_SINGLE)))
4108 : : {
4109 : 580 : if (as->lower[d-1] && as->lower[d-1]->expr_type == EXPR_CONSTANT)
4110 : : {
4111 : 355 : gfc_free_expr (result);
4112 : 355 : return gfc_copy_expr (as->lower[d-1]);
4113 : : }
4114 : :
4115 : 225 : goto returnNull;
4116 : : }
4117 : :
4118 : 11180 : result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
4119 : :
4120 : : /* Then, we need to know the extent of the given dimension. */
4121 : 11180 : if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
4122 : : {
4123 : 10677 : gfc_expr *declared_bound;
4124 : 10677 : int empty_bound;
4125 : 10677 : bool constant_lbound, constant_ubound;
4126 : :
4127 : 10677 : l = as->lower[d-1];
4128 : 10677 : u = as->upper[d-1];
4129 : :
4130 : 10677 : gcc_assert (l != NULL);
4131 : :
4132 : 10677 : constant_lbound = l->expr_type == EXPR_CONSTANT;
4133 : 10677 : constant_ubound = u && u->expr_type == EXPR_CONSTANT;
4134 : :
4135 : 10677 : empty_bound = upper ? 0 : 1;
4136 : 10677 : declared_bound = upper ? u : l;
4137 : :
4138 : 10677 : if ((!upper && !constant_lbound)
4139 : 9758 : || (upper && !constant_ubound))
4140 : 2262 : goto returnNull;
4141 : :
4142 : 8415 : if (!coarray)
4143 : : {
4144 : : /* For {L,U}BOUND, the value depends on whether the array
4145 : : is empty. We can nevertheless simplify if the declared bound
4146 : : has the same value as that of an empty array, in which case
4147 : : the result isn't dependent on the array emptiness. */
4148 : 7865 : if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0)
4149 : 3819 : mpz_set_si (result->value.integer, empty_bound);
4150 : 4046 : else if (!constant_lbound || !constant_ubound)
4151 : : /* Array emptiness can't be determined, we can't simplify. */
4152 : 1815 : goto returnNull;
4153 : 2231 : else if (mpz_cmp (l->value.integer, u->value.integer) > 0)
4154 : 97 : mpz_set_si (result->value.integer, empty_bound);
4155 : : else
4156 : 2134 : mpz_set (result->value.integer, declared_bound->value.integer);
4157 : : }
4158 : : else
4159 : 550 : mpz_set (result->value.integer, declared_bound->value.integer);
4160 : : }
4161 : : else
4162 : : {
4163 : 503 : if (upper)
4164 : : {
4165 : : int d2 = 0, cnt = 0;
4166 : 523 : for (int idx = 0; idx < ref->u.ar.dimen; ++idx)
4167 : : {
4168 : 523 : if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT)
4169 : 120 : d2++;
4170 : 403 : else if (cnt < d - 1)
4171 : 102 : cnt++;
4172 : : else
4173 : : break;
4174 : : }
4175 : 301 : if (!gfc_ref_dimen_size (&ref->u.ar, d2 + d - 1, &result->value.integer, NULL))
4176 : 73 : goto returnNull;
4177 : : }
4178 : : else
4179 : 202 : mpz_set_si (result->value.integer, (long int) 1);
4180 : : }
4181 : :
4182 : 8069 : done:
4183 : 8069 : return range_check (result, upper ? "UBOUND" : "LBOUND");
4184 : :
4185 : 4750 : returnNull:
4186 : 4750 : gfc_free_expr (result);
4187 : 4750 : return NULL;
4188 : : }
4189 : :
4190 : :
4191 : : static gfc_expr *
4192 : 32697 : simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4193 : : {
4194 : 32697 : gfc_ref *ref;
4195 : 32697 : gfc_array_spec *as;
4196 : 32697 : ar_type type = AR_UNKNOWN;
4197 : 32697 : int d;
4198 : :
4199 : 32697 : if (array->ts.type == BT_CLASS)
4200 : : return NULL;
4201 : :
4202 : 31371 : if (array->expr_type != EXPR_VARIABLE)
4203 : : {
4204 : 1242 : as = NULL;
4205 : 1242 : ref = NULL;
4206 : 1242 : goto done;
4207 : : }
4208 : :
4209 : : /* Do not attempt to resolve if error has already been issued. */
4210 : 30129 : if (array->symtree->n.sym->error)
4211 : : return NULL;
4212 : :
4213 : : /* Follow any component references. */
4214 : 30128 : as = array->symtree->n.sym->as;
4215 : 30958 : for (ref = array->ref; ref; ref = ref->next)
4216 : : {
4217 : 30958 : switch (ref->type)
4218 : : {
4219 : 30262 : case REF_ARRAY:
4220 : 30262 : type = ref->u.ar.type;
4221 : 30262 : switch (ref->u.ar.type)
4222 : : {
4223 : 134 : case AR_ELEMENT:
4224 : 134 : as = NULL;
4225 : 134 : continue;
4226 : :
4227 : 29265 : case AR_FULL:
4228 : : /* We're done because 'as' has already been set in the
4229 : : previous iteration. */
4230 : 29265 : goto done;
4231 : :
4232 : : case AR_UNKNOWN:
4233 : : return NULL;
4234 : :
4235 : 863 : case AR_SECTION:
4236 : 863 : as = ref->u.ar.as;
4237 : 863 : goto done;
4238 : : }
4239 : :
4240 : 0 : gcc_unreachable ();
4241 : :
4242 : 696 : case REF_COMPONENT:
4243 : 696 : as = ref->u.c.component->as;
4244 : 696 : continue;
4245 : :
4246 : 0 : case REF_SUBSTRING:
4247 : 0 : case REF_INQUIRY:
4248 : 0 : continue;
4249 : : }
4250 : : }
4251 : :
4252 : 0 : gcc_unreachable ();
4253 : :
4254 : 31370 : done:
4255 : :
4256 : 31370 : if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
4257 : 11596 : || (as->type == AS_ASSUMED_SHAPE && upper)))
4258 : : return NULL;
4259 : :
4260 : : /* 'array' shall not be an unallocated allocatable variable or a pointer that
4261 : : is not associated. */
4262 : 10710 : if (array->expr_type == EXPR_VARIABLE
4263 : 10710 : && (gfc_expr_attr (array).allocatable || gfc_expr_attr (array).pointer))
4264 : 6 : return NULL;
4265 : :
4266 : 10704 : gcc_assert (!as
4267 : : || (as->type != AS_DEFERRED
4268 : : && array->expr_type == EXPR_VARIABLE
4269 : : && !gfc_expr_attr (array).allocatable
4270 : : && !gfc_expr_attr (array).pointer));
4271 : :
4272 : 10704 : if (dim == NULL)
4273 : : {
4274 : : /* Multi-dimensional bounds. */
4275 : 1579 : gfc_expr *bounds[GFC_MAX_DIMENSIONS];
4276 : 1579 : gfc_expr *e;
4277 : 1579 : int k;
4278 : :
4279 : : /* UBOUND(ARRAY) is not valid for an assumed-size array. */
4280 : 1579 : if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE)
4281 : : {
4282 : : /* An error message will be emitted in
4283 : : check_assumed_size_reference (resolve.cc). */
4284 : : return &gfc_bad_expr;
4285 : : }
4286 : :
4287 : : /* Simplify the bounds for each dimension. */
4288 : 4094 : for (d = 0; d < array->rank; d++)
4289 : : {
4290 : 2880 : bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
4291 : : false);
4292 : 2880 : if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
4293 : : {
4294 : : int j;
4295 : :
4296 : 400 : for (j = 0; j < d; j++)
4297 : 36 : gfc_free_expr (bounds[j]);
4298 : :
4299 : 364 : if (gfc_seen_div0)
4300 : : return &gfc_bad_expr;
4301 : : else
4302 : : return bounds[d];
4303 : : }
4304 : : }
4305 : :
4306 : : /* Allocate the result expression. */
4307 : 1897 : k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
4308 : : gfc_default_integer_kind);
4309 : 1214 : if (k == -1)
4310 : : return &gfc_bad_expr;
4311 : :
4312 : 1214 : e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
4313 : :
4314 : : /* The result is a rank 1 array; its size is the rank of the first
4315 : : argument to {L,U}BOUND. */
4316 : 1214 : e->rank = 1;
4317 : 1214 : e->shape = gfc_get_shape (1);
4318 : 1214 : mpz_init_set_ui (e->shape[0], array->rank);
4319 : :
4320 : : /* Create the constructor for this array. */
4321 : 4908 : for (d = 0; d < array->rank; d++)
4322 : 2480 : gfc_constructor_append_expr (&e->value.constructor,
4323 : : bounds[d], &e->where);
4324 : :
4325 : : return e;
4326 : : }
4327 : : else
4328 : : {
4329 : : /* A DIM argument is specified. */
4330 : 9125 : if (dim->expr_type != EXPR_CONSTANT)
4331 : : return NULL;
4332 : :
4333 : 9125 : d = mpz_get_si (dim->value.integer);
4334 : :
4335 : 9125 : if ((d < 1 || d > array->rank)
4336 : 9125 : || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
4337 : : {
4338 : 0 : gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4339 : 0 : return &gfc_bad_expr;
4340 : : }
4341 : :
4342 : 8708 : if (as && as->type == AS_ASSUMED_RANK)
4343 : : return NULL;
4344 : :
4345 : 9125 : return simplify_bound_dim (array, kind, d, upper, as, ref, false);
4346 : : }
4347 : : }
4348 : :
4349 : :
4350 : : static gfc_expr *
4351 : 1418 : simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4352 : : {
4353 : 1418 : gfc_ref *ref;
4354 : 1418 : gfc_array_spec *as;
4355 : 1418 : int d;
4356 : :
4357 : 1418 : if (array->expr_type != EXPR_VARIABLE)
4358 : : return NULL;
4359 : :
4360 : : /* Follow any component references. */
4361 : 120 : as = (array->ts.type == BT_CLASS && CLASS_DATA (array))
4362 : 1537 : ? CLASS_DATA (array)->as
4363 : 1299 : : array->symtree->n.sym->as;
4364 : 1597 : for (ref = array->ref; ref; ref = ref->next)
4365 : : {
4366 : 1596 : switch (ref->type)
4367 : : {
4368 : 1417 : case REF_ARRAY:
4369 : 1417 : switch (ref->u.ar.type)
4370 : : {
4371 : 321 : case AR_ELEMENT:
4372 : 321 : if (ref->u.ar.as->corank > 0)
4373 : : {
4374 : 321 : gcc_assert (as == ref->u.ar.as);
4375 : 321 : goto done;
4376 : : }
4377 : 0 : as = NULL;
4378 : 0 : continue;
4379 : :
4380 : 1096 : case AR_FULL:
4381 : : /* We're done because 'as' has already been set in the
4382 : : previous iteration. */
4383 : 1096 : goto done;
4384 : :
4385 : : case AR_UNKNOWN:
4386 : : return NULL;
4387 : :
4388 : 0 : case AR_SECTION:
4389 : 0 : as = ref->u.ar.as;
4390 : 0 : goto done;
4391 : : }
4392 : :
4393 : 0 : gcc_unreachable ();
4394 : :
4395 : 179 : case REF_COMPONENT:
4396 : 179 : as = ref->u.c.component->as;
4397 : 179 : continue;
4398 : :
4399 : 0 : case REF_SUBSTRING:
4400 : 0 : case REF_INQUIRY:
4401 : 0 : continue;
4402 : : }
4403 : : }
4404 : :
4405 : 1 : if (!as)
4406 : 0 : gcc_unreachable ();
4407 : :
4408 : 1 : done:
4409 : :
4410 : 1418 : if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
4411 : : return NULL;
4412 : :
4413 : 730 : if (dim == NULL)
4414 : : {
4415 : : /* Multi-dimensional cobounds. */
4416 : : gfc_expr *bounds[GFC_MAX_DIMENSIONS];
4417 : : gfc_expr *e;
4418 : : int k;
4419 : :
4420 : : /* Simplify the cobounds for each dimension. */
4421 : 681 : for (d = 0; d < as->corank; d++)
4422 : : {
4423 : 592 : bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
4424 : : upper, as, ref, true);
4425 : 592 : if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
4426 : : {
4427 : : int j;
4428 : :
4429 : 266 : for (j = 0; j < d; j++)
4430 : 118 : gfc_free_expr (bounds[j]);
4431 : : return bounds[d];
4432 : : }
4433 : : }
4434 : :
4435 : : /* Allocate the result expression. */
4436 : 89 : e = gfc_get_expr ();
4437 : 89 : e->where = array->where;
4438 : 89 : e->expr_type = EXPR_ARRAY;
4439 : 89 : e->ts.type = BT_INTEGER;
4440 : 156 : k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
4441 : : gfc_default_integer_kind);
4442 : 89 : if (k == -1)
4443 : : {
4444 : 0 : gfc_free_expr (e);
4445 : 0 : return &gfc_bad_expr;
4446 : : }
4447 : 89 : e->ts.kind = k;
4448 : :
4449 : : /* The result is a rank 1 array; its size is the rank of the first
4450 : : argument to {L,U}COBOUND. */
4451 : 89 : e->rank = 1;
4452 : 89 : e->shape = gfc_get_shape (1);
4453 : 89 : mpz_init_set_ui (e->shape[0], as->corank);
4454 : :
4455 : : /* Create the constructor for this array. */
4456 : 504 : for (d = 0; d < as->corank; d++)
4457 : 326 : gfc_constructor_append_expr (&e->value.constructor,
4458 : : bounds[d], &e->where);
4459 : : return e;
4460 : : }
4461 : : else
4462 : : {
4463 : : /* A DIM argument is specified. */
4464 : 493 : if (dim->expr_type != EXPR_CONSTANT)
4465 : : return NULL;
4466 : :
4467 : 353 : d = mpz_get_si (dim->value.integer);
4468 : :
4469 : 353 : if (d < 1 || d > as->corank)
4470 : : {
4471 : 0 : gfc_error ("DIM argument at %L is out of bounds", &dim->where);
4472 : 0 : return &gfc_bad_expr;
4473 : : }
4474 : :
4475 : 353 : return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
4476 : : }
4477 : : }
4478 : :
4479 : :
4480 : : gfc_expr *
4481 : 19693 : gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4482 : : {
4483 : 19693 : return simplify_bound (array, dim, kind, 0);
4484 : : }
4485 : :
4486 : :
4487 : : gfc_expr *
4488 : 493 : gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4489 : : {
4490 : 493 : return simplify_cobound (array, dim, kind, 0);
4491 : : }
4492 : :
4493 : : gfc_expr *
4494 : 1068 : gfc_simplify_leadz (gfc_expr *e)
4495 : : {
4496 : 1068 : unsigned long lz, bs;
4497 : 1068 : int i;
4498 : :
4499 : 1068 : if (e->expr_type != EXPR_CONSTANT)
4500 : : return NULL;
4501 : :
4502 : 258 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
4503 : 258 : bs = gfc_integer_kinds[i].bit_size;
4504 : 258 : if (mpz_cmp_si (e->value.integer, 0) == 0)
4505 : : lz = bs;
4506 : 222 : else if (mpz_cmp_si (e->value.integer, 0) < 0)
4507 : : lz = 0;
4508 : : else
4509 : 132 : lz = bs - mpz_sizeinbase (e->value.integer, 2);
4510 : :
4511 : 258 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
4512 : : }
4513 : :
4514 : :
4515 : : /* Check for constant length of a substring. */
4516 : :
4517 : : static bool
4518 : 14491 : substring_has_constant_len (gfc_expr *e)
4519 : : {
4520 : 14491 : gfc_ref *ref;
4521 : 14491 : HOST_WIDE_INT istart, iend, length;
4522 : 14491 : bool equal_length = false;
4523 : :
4524 : 14491 : if (e->ts.type != BT_CHARACTER)
4525 : : return false;
4526 : :
4527 : 20640 : for (ref = e->ref; ref; ref = ref->next)
4528 : 6668 : if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY)
4529 : : break;
4530 : :
4531 : 14491 : if (!ref
4532 : 519 : || ref->type != REF_SUBSTRING
4533 : 519 : || !ref->u.ss.start
4534 : 519 : || ref->u.ss.start->expr_type != EXPR_CONSTANT
4535 : 206 : || !ref->u.ss.end
4536 : 206 : || ref->u.ss.end->expr_type != EXPR_CONSTANT)
4537 : : return false;
4538 : :
4539 : : /* Basic checks on substring starting and ending indices. */
4540 : 206 : if (!gfc_resolve_substring (ref, &equal_length))
4541 : : return false;
4542 : :
4543 : 206 : istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer);
4544 : 206 : iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer);
4545 : :
4546 : 206 : if (istart <= iend)
4547 : 198 : length = iend - istart + 1;
4548 : : else
4549 : : length = 0;
4550 : :
4551 : : /* Fix substring length. */
4552 : 206 : e->value.character.length = length;
4553 : :
4554 : 206 : return true;
4555 : : }
4556 : :
4557 : :
4558 : : gfc_expr *
4559 : 15001 : gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
4560 : : {
4561 : 15001 : gfc_expr *result;
4562 : 15001 : int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
4563 : :
4564 : 15001 : if (k == -1)
4565 : : return &gfc_bad_expr;
4566 : :
4567 : 15001 : if (e->expr_type == EXPR_CONSTANT
4568 : 15001 : || substring_has_constant_len (e))
4569 : : {
4570 : 716 : result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4571 : 716 : mpz_set_si (result->value.integer, e->value.character.length);
4572 : 716 : return range_check (result, "LEN");
4573 : : }
4574 : 14285 : else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
4575 : 4781 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
4576 : 2780 : && e->ts.u.cl->length->ts.type == BT_INTEGER)
4577 : : {
4578 : 2780 : result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
4579 : 2780 : mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
4580 : 2780 : return range_check (result, "LEN");
4581 : : }
4582 : 11505 : else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
4583 : 9947 : && e->symtree->n.sym)
4584 : : {
4585 : 9947 : if (e->symtree->n.sym->ts.type != BT_DERIVED
4586 : 9553 : && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
4587 : 811 : && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
4588 : 361 : && e->symtree->n.sym->assoc->target->symtree->n.sym
4589 : 361 : && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
4590 : : /* The expression in assoc->target points to a ref to the _data
4591 : : component of the unlimited polymorphic entity. To get the _len
4592 : : component the last _data ref needs to be stripped and a ref to the
4593 : : _len component added. */
4594 : 361 : return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
4595 : 9586 : else if (e->symtree->n.sym->ts.type == BT_DERIVED
4596 : 394 : && e->ref && e->ref->type == REF_COMPONENT
4597 : 394 : && e->ref->u.c.component->attr.pdt_string
4598 : 36 : && e->ref->u.c.component->ts.type == BT_CHARACTER
4599 : 36 : && e->ref->u.c.component->ts.u.cl->length)
4600 : : {
4601 : 36 : if (gfc_init_expr_flag)
4602 : : {
4603 : 6 : gfc_expr* tmp;
4604 : 12 : tmp = gfc_pdt_find_component_copy_initializer (e->symtree->n.sym,
4605 : : e->ref->u.c
4606 : : .component->ts.u.cl
4607 : 6 : ->length->symtree
4608 : : ->name);
4609 : 6 : if (tmp)
4610 : : return tmp;
4611 : : }
4612 : : else
4613 : : {
4614 : 30 : gfc_expr *len_expr = gfc_copy_expr (e);
4615 : 30 : gfc_free_ref_list (len_expr->ref);
4616 : 30 : len_expr->ref = NULL;
4617 : 30 : gfc_find_component (len_expr->symtree->n.sym->ts.u.derived, e->ref
4618 : 30 : ->u.c.component->ts.u.cl->length->symtree
4619 : : ->name,
4620 : : false, true, &len_expr->ref);
4621 : 30 : len_expr->ts = len_expr->ref->u.c.component->ts;
4622 : 30 : return len_expr;
4623 : : }
4624 : : }
4625 : : }
4626 : : return NULL;
4627 : : }
4628 : :
4629 : :
4630 : : gfc_expr *
4631 : 3711 : gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
4632 : : {
4633 : 3711 : gfc_expr *result;
4634 : 3711 : size_t count, len, i;
4635 : 3711 : int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
4636 : :
4637 : 3711 : if (k == -1)
4638 : : return &gfc_bad_expr;
4639 : :
4640 : 3711 : if (e->expr_type != EXPR_CONSTANT)
4641 : : return NULL;
4642 : :
4643 : 160 : len = e->value.character.length;
4644 : 755 : for (count = 0, i = 1; i <= len; i++)
4645 : 743 : if (e->value.character.string[len - i] == ' ')
4646 : 595 : count++;
4647 : : else
4648 : : break;
4649 : :
4650 : 160 : result = gfc_get_int_expr (k, &e->where, len - count);
4651 : 160 : return range_check (result, "LEN_TRIM");
4652 : : }
4653 : :
4654 : : gfc_expr *
4655 : 50 : gfc_simplify_lgamma (gfc_expr *x)
4656 : : {
4657 : 50 : gfc_expr *result;
4658 : 50 : int sg;
4659 : :
4660 : 50 : if (x->expr_type != EXPR_CONSTANT)
4661 : : return NULL;
4662 : :
4663 : 42 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4664 : 42 : mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
4665 : :
4666 : 42 : return range_check (result, "LGAMMA");
4667 : : }
4668 : :
4669 : :
4670 : : gfc_expr *
4671 : 70 : gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
4672 : : {
4673 : 70 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4674 : : return NULL;
4675 : :
4676 : 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4677 : 2 : gfc_compare_string (a, b) >= 0);
4678 : : }
4679 : :
4680 : :
4681 : : gfc_expr *
4682 : 91 : gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
4683 : : {
4684 : 91 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4685 : : return NULL;
4686 : :
4687 : 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4688 : 2 : gfc_compare_string (a, b) > 0);
4689 : : }
4690 : :
4691 : :
4692 : : gfc_expr *
4693 : 79 : gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
4694 : : {
4695 : 79 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4696 : : return NULL;
4697 : :
4698 : 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4699 : 2 : gfc_compare_string (a, b) <= 0);
4700 : : }
4701 : :
4702 : :
4703 : : gfc_expr *
4704 : 82 : gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
4705 : : {
4706 : 82 : if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4707 : : return NULL;
4708 : :
4709 : 1 : return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4710 : 2 : gfc_compare_string (a, b) < 0);
4711 : : }
4712 : :
4713 : :
4714 : : gfc_expr *
4715 : 520 : gfc_simplify_log (gfc_expr *x)
4716 : : {
4717 : 520 : gfc_expr *result;
4718 : :
4719 : 520 : if (x->expr_type != EXPR_CONSTANT)
4720 : : return NULL;
4721 : :
4722 : 215 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4723 : :
4724 : 215 : switch (x->ts.type)
4725 : : {
4726 : 116 : case BT_REAL:
4727 : 116 : if (mpfr_sgn (x->value.real) <= 0)
4728 : : {
4729 : 0 : gfc_error ("Argument of LOG at %L cannot be less than or equal "
4730 : : "to zero", &x->where);
4731 : 0 : gfc_free_expr (result);
4732 : 0 : return &gfc_bad_expr;
4733 : : }
4734 : :
4735 : 116 : mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
4736 : 116 : break;
4737 : :
4738 : 99 : case BT_COMPLEX:
4739 : 99 : if (mpfr_zero_p (mpc_realref (x->value.complex))
4740 : 0 : && mpfr_zero_p (mpc_imagref (x->value.complex)))
4741 : : {
4742 : 0 : gfc_error ("Complex argument of LOG at %L cannot be zero",
4743 : : &x->where);
4744 : 0 : gfc_free_expr (result);
4745 : 0 : return &gfc_bad_expr;
4746 : : }
4747 : :
4748 : 99 : gfc_set_model_kind (x->ts.kind);
4749 : 99 : mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4750 : 99 : break;
4751 : :
4752 : 0 : default:
4753 : 0 : gfc_internal_error ("gfc_simplify_log: bad type");
4754 : : }
4755 : :
4756 : 215 : return range_check (result, "LOG");
4757 : : }
4758 : :
4759 : :
4760 : : gfc_expr *
4761 : 408 : gfc_simplify_log10 (gfc_expr *x)
4762 : : {
4763 : 408 : gfc_expr *result;
4764 : :
4765 : 408 : if (x->expr_type != EXPR_CONSTANT)
4766 : : return NULL;
4767 : :
4768 : 97 : if (mpfr_sgn (x->value.real) <= 0)
4769 : : {
4770 : 0 : gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4771 : : "to zero", &x->where);
4772 : 0 : return &gfc_bad_expr;
4773 : : }
4774 : :
4775 : 97 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4776 : 97 : mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
4777 : :
4778 : 97 : return range_check (result, "LOG10");
4779 : : }
4780 : :
4781 : :
4782 : : gfc_expr *
4783 : 52 : gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
4784 : : {
4785 : 52 : int kind;
4786 : :
4787 : 52 : kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
4788 : 52 : if (kind < 0)
4789 : : return &gfc_bad_expr;
4790 : :
4791 : 52 : if (e->expr_type != EXPR_CONSTANT)
4792 : : return NULL;
4793 : :
4794 : 4 : return gfc_get_logical_expr (kind, &e->where, e->value.logical);
4795 : : }
4796 : :
4797 : :
4798 : : gfc_expr*
4799 : 1197 : gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
4800 : : {
4801 : 1197 : gfc_expr *result;
4802 : 1197 : int row, result_rows, col, result_columns;
4803 : 1197 : int stride_a, offset_a, stride_b, offset_b;
4804 : :
4805 : 1197 : if (!is_constant_array_expr (matrix_a)
4806 : 1197 : || !is_constant_array_expr (matrix_b))
4807 : 1146 : return NULL;
4808 : :
4809 : : /* MATMUL should do mixed-mode arithmetic. Set the result type. */
4810 : 51 : if (matrix_a->ts.type != matrix_b->ts.type)
4811 : : {
4812 : 12 : gfc_expr e;
4813 : 12 : e.expr_type = EXPR_OP;
4814 : 12 : gfc_clear_ts (&e.ts);
4815 : 12 : e.value.op.op = INTRINSIC_NONE;
4816 : 12 : e.value.op.op1 = matrix_a;
4817 : 12 : e.value.op.op2 = matrix_b;
4818 : 12 : gfc_type_convert_binary (&e, 1);
4819 : 12 : result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where);
4820 : : }
4821 : : else
4822 : : {
4823 : 39 : result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind,
4824 : : &matrix_a->where);
4825 : : }
4826 : :
4827 : 51 : if (matrix_a->rank == 1 && matrix_b->rank == 2)
4828 : : {
4829 : 7 : result_rows = 1;
4830 : 7 : result_columns = mpz_get_si (matrix_b->shape[1]);
4831 : 7 : stride_a = 1;
4832 : 7 : stride_b = mpz_get_si (matrix_b->shape[0]);
4833 : :
4834 : 7 : result->rank = 1;
4835 : 7 : result->shape = gfc_get_shape (result->rank);
4836 : 7 : mpz_init_set_si (result->shape[0], result_columns);
4837 : : }
4838 : 44 : else if (matrix_a->rank == 2 && matrix_b->rank == 1)
4839 : : {
4840 : 6 : result_rows = mpz_get_si (matrix_a->shape[0]);
4841 : 6 : result_columns = 1;
4842 : 6 : stride_a = mpz_get_si (matrix_a->shape[0]);
4843 : 6 : stride_b = 1;
4844 : :
4845 : 6 : result->rank = 1;
4846 : 6 : result->shape = gfc_get_shape (result->rank);
4847 : 6 : mpz_init_set_si (result->shape[0], result_rows);
4848 : : }
4849 : 38 : else if (matrix_a->rank == 2 && matrix_b->rank == 2)
4850 : : {
4851 : 38 : result_rows = mpz_get_si (matrix_a->shape[0]);
4852 : 38 : result_columns = mpz_get_si (matrix_b->shape[1]);
4853 : 38 : stride_a = mpz_get_si (matrix_a->shape[0]);
4854 : 38 : stride_b = mpz_get_si (matrix_b->shape[0]);
4855 : :
4856 : 38 : result->rank = 2;
4857 : 38 : result->shape = gfc_get_shape (result->rank);
4858 : 38 : mpz_init_set_si (result->shape[0], result_rows);
4859 : 38 : mpz_init_set_si (result->shape[1], result_columns);
4860 : : }
4861 : : else
4862 : 0 : gcc_unreachable();
4863 : :
4864 : 51 : offset_b = 0;
4865 : 175 : for (col = 0; col < result_columns; ++col)
4866 : : {
4867 : : offset_a = 0;
4868 : :
4869 : 434 : for (row = 0; row < result_rows; ++row)
4870 : : {
4871 : 310 : gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
4872 : : matrix_b, 1, offset_b, false);
4873 : 310 : gfc_constructor_append_expr (&result->value.constructor,
4874 : : e, NULL);
4875 : :
4876 : 310 : offset_a += 1;
4877 : : }
4878 : :
4879 : 124 : offset_b += stride_b;
4880 : : }
4881 : :
4882 : : return result;
4883 : : }
4884 : :
4885 : :
4886 : : gfc_expr *
4887 : 285 : gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
4888 : : {
4889 : 285 : gfc_expr *result;
4890 : 285 : int kind, arg, k;
4891 : :
4892 : 285 : if (i->expr_type != EXPR_CONSTANT)
4893 : : return NULL;
4894 : :
4895 : 213 : kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
4896 : 213 : if (kind == -1)
4897 : : return &gfc_bad_expr;
4898 : 213 : k = gfc_validate_kind (BT_INTEGER, kind, false);
4899 : :
4900 : 213 : bool fail = gfc_extract_int (i, &arg);
4901 : 213 : gcc_assert (!fail);
4902 : :
4903 : 213 : if (!gfc_check_mask (i, kind_arg))
4904 : : return &gfc_bad_expr;
4905 : :
4906 : 211 : result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4907 : :
4908 : : /* MASKR(n) = 2^n - 1 */
4909 : 211 : mpz_set_ui (result->value.integer, 1);
4910 : 211 : mpz_mul_2exp (result->value.integer, result->value.integer, arg);
4911 : 211 : mpz_sub_ui (result->value.integer, result->value.integer, 1);
4912 : :
4913 : 211 : gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4914 : :
4915 : 211 : return result;
4916 : : }
4917 : :
4918 : :
4919 : : gfc_expr *
4920 : 297 : gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
4921 : : {
4922 : 297 : gfc_expr *result;
4923 : 297 : int kind, arg, k;
4924 : 297 : mpz_t z;
4925 : :
4926 : 297 : if (i->expr_type != EXPR_CONSTANT)
4927 : : return NULL;
4928 : :
4929 : 217 : kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
4930 : 217 : if (kind == -1)
4931 : : return &gfc_bad_expr;
4932 : 217 : k = gfc_validate_kind (BT_INTEGER, kind, false);
4933 : :
4934 : 217 : bool fail = gfc_extract_int (i, &arg);
4935 : 217 : gcc_assert (!fail);
4936 : :
4937 : 217 : if (!gfc_check_mask (i, kind_arg))
4938 : : return &gfc_bad_expr;
4939 : :
4940 : 213 : result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4941 : :
4942 : : /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4943 : 213 : mpz_init_set_ui (z, 1);
4944 : 213 : mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
4945 : 213 : mpz_set_ui (result->value.integer, 1);
4946 : 213 : mpz_mul_2exp (result->value.integer, result->value.integer,
4947 : 213 : gfc_integer_kinds[k].bit_size - arg);
4948 : 213 : mpz_sub (result->value.integer, z, result->value.integer);
4949 : 213 : mpz_clear (z);
4950 : :
4951 : 213 : gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4952 : :
4953 : 213 : return result;
4954 : : }
4955 : :
4956 : :
4957 : : gfc_expr *
4958 : 3939 : gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4959 : : {
4960 : 3939 : gfc_expr * result;
4961 : 3939 : gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
4962 : :
4963 : 3939 : if (mask->expr_type == EXPR_CONSTANT)
4964 : : {
4965 : : /* The standard requires evaluation of all function arguments.
4966 : : Simplify only when the other dropped argument (FSOURCE or TSOURCE)
4967 : : is a constant expression. */
4968 : 699 : if (mask->value.logical)
4969 : : {
4970 : 482 : if (!gfc_is_constant_expr (fsource))
4971 : : return NULL;
4972 : 168 : result = gfc_copy_expr (tsource);
4973 : : }
4974 : : else
4975 : : {
4976 : 217 : if (!gfc_is_constant_expr (tsource))
4977 : : return NULL;
4978 : 67 : result = gfc_copy_expr (fsource);
4979 : : }
4980 : :
4981 : : /* Parenthesis is needed to get lower bounds of 1. */
4982 : 235 : result = gfc_get_parentheses (result);
4983 : 235 : gfc_simplify_expr (result, 1);
4984 : 235 : return result;
4985 : : }
4986 : :
4987 : 769 : if (!mask->rank || !is_constant_array_expr (mask)
4988 : 3287 : || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
4989 : 3221 : return NULL;
4990 : :
4991 : 19 : result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
4992 : : &tsource->where);
4993 : 19 : if (tsource->ts.type == BT_DERIVED)
4994 : 1 : result->ts.u.derived = tsource->ts.u.derived;
4995 : 18 : else if (tsource->ts.type == BT_CHARACTER)
4996 : 6 : result->ts.u.cl = tsource->ts.u.cl;
4997 : :
4998 : 19 : tsource_ctor = gfc_constructor_first (tsource->value.constructor);
4999 : 19 : fsource_ctor = gfc_constructor_first (fsource->value.constructor);
5000 : 19 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5001 : :
5002 : 87 : while (mask_ctor)
5003 : : {
5004 : 49 : if (mask_ctor->expr->value.logical)
5005 : 31 : gfc_constructor_append_expr (&result->value.constructor,
5006 : : gfc_copy_expr (tsource_ctor->expr),
5007 : : NULL);
5008 : : else
5009 : 18 : gfc_constructor_append_expr (&result->value.constructor,
5010 : : gfc_copy_expr (fsource_ctor->expr),
5011 : : NULL);
5012 : 49 : tsource_ctor = gfc_constructor_next (tsource_ctor);
5013 : 49 : fsource_ctor = gfc_constructor_next (fsource_ctor);
5014 : 49 : mask_ctor = gfc_constructor_next (mask_ctor);
5015 : : }
5016 : :
5017 : 19 : result->shape = gfc_get_shape (1);
5018 : 19 : gfc_array_size (result, &result->shape[0]);
5019 : :
5020 : 19 : return result;
5021 : : }
5022 : :
5023 : :
5024 : : gfc_expr *
5025 : 342 : gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
5026 : : {
5027 : 342 : mpz_t arg1, arg2, mask;
5028 : 342 : gfc_expr *result;
5029 : :
5030 : 342 : if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
5031 : 282 : || mask_expr->expr_type != EXPR_CONSTANT)
5032 : : return NULL;
5033 : :
5034 : 282 : result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
5035 : :
5036 : : /* Convert all argument to unsigned. */
5037 : 282 : mpz_init_set (arg1, i->value.integer);
5038 : 282 : mpz_init_set (arg2, j->value.integer);
5039 : 282 : mpz_init_set (mask, mask_expr->value.integer);
5040 : :
5041 : : /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
5042 : 282 : mpz_and (arg1, arg1, mask);
5043 : 282 : mpz_com (mask, mask);
5044 : 282 : mpz_and (arg2, arg2, mask);
5045 : 282 : mpz_ior (result->value.integer, arg1, arg2);
5046 : :
5047 : 282 : mpz_clear (arg1);
5048 : 282 : mpz_clear (arg2);
5049 : 282 : mpz_clear (mask);
5050 : :
5051 : 282 : return result;
5052 : : }
5053 : :
5054 : :
5055 : : /* Selects between current value and extremum for simplify_min_max
5056 : : and simplify_minval_maxval. */
5057 : : static int
5058 : 2676 : min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
5059 : : {
5060 : 2676 : int ret;
5061 : :
5062 : 2676 : switch (arg->ts.type)
5063 : : {
5064 : 1573 : case BT_INTEGER:
5065 : 1573 : if (extremum->ts.kind < arg->ts.kind)
5066 : 6 : extremum->ts.kind = arg->ts.kind;
5067 : 1573 : ret = mpz_cmp (arg->value.integer,
5068 : 1573 : extremum->value.integer) * sign;
5069 : 1573 : if (ret > 0)
5070 : 1035 : mpz_set (extremum->value.integer, arg->value.integer);
5071 : : break;
5072 : :
5073 : 606 : case BT_REAL:
5074 : 606 : if (extremum->ts.kind < arg->ts.kind)
5075 : 30 : extremum->ts.kind = arg->ts.kind;
5076 : 606 : if (mpfr_nan_p (extremum->value.real))
5077 : : {
5078 : 192 : ret = 1;
5079 : 192 : mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
5080 : : }
5081 : 414 : else if (mpfr_nan_p (arg->value.real))
5082 : : ret = -1;
5083 : : else
5084 : : {
5085 : 294 : ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign;
5086 : 294 : if (ret > 0)
5087 : 144 : mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
5088 : : }
5089 : : break;
5090 : :
5091 : 497 : case BT_CHARACTER:
5092 : : #define LENGTH(x) ((x)->value.character.length)
5093 : : #define STRING(x) ((x)->value.character.string)
5094 : 497 : if (LENGTH (extremum) < LENGTH(arg))
5095 : : {
5096 : 12 : gfc_char_t *tmp = STRING(extremum);
5097 : :
5098 : 12 : STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
5099 : 12 : memcpy (STRING(extremum), tmp,
5100 : 12 : LENGTH(extremum) * sizeof (gfc_char_t));
5101 : 12 : gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
5102 : 12 : LENGTH(arg) - LENGTH(extremum));
5103 : 12 : STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
5104 : 12 : LENGTH(extremum) = LENGTH(arg);
5105 : 12 : free (tmp);
5106 : : }
5107 : 497 : ret = gfc_compare_string (arg, extremum) * sign;
5108 : 497 : if (ret > 0)
5109 : : {
5110 : 187 : free (STRING(extremum));
5111 : 187 : STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
5112 : 187 : memcpy (STRING(extremum), STRING(arg),
5113 : 187 : LENGTH(arg) * sizeof (gfc_char_t));
5114 : 187 : gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
5115 : 187 : LENGTH(extremum) - LENGTH(arg));
5116 : 187 : STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
5117 : : }
5118 : : #undef LENGTH
5119 : : #undef STRING
5120 : : break;
5121 : :
5122 : 0 : default:
5123 : 0 : gfc_internal_error ("simplify_min_max(): Bad type in arglist");
5124 : : }
5125 : 2676 : if (back_val && ret == 0)
5126 : 59 : ret = 1;
5127 : :
5128 : 2676 : return ret;
5129 : : }
5130 : :
5131 : :
5132 : : /* This function is special since MAX() can take any number of
5133 : : arguments. The simplified expression is a rewritten version of the
5134 : : argument list containing at most one constant element. Other
5135 : : constant elements are deleted. Because the argument list has
5136 : : already been checked, this function always succeeds. sign is 1 for
5137 : : MAX(), -1 for MIN(). */
5138 : :
5139 : : static gfc_expr *
5140 : 5808 : simplify_min_max (gfc_expr *expr, int sign)
5141 : : {
5142 : 5808 : int tmp1, tmp2;
5143 : 5808 : gfc_actual_arglist *arg, *last, *extremum;
5144 : 5808 : gfc_expr *tmp, *ret;
5145 : 5808 : const char *fname;
5146 : :
5147 : 5808 : last = NULL;
5148 : 5808 : extremum = NULL;
5149 : :
5150 : 5808 : arg = expr->value.function.actual;
5151 : :
5152 : 18710 : for (; arg; last = arg, arg = arg->next)
5153 : : {
5154 : 12902 : if (arg->expr->expr_type != EXPR_CONSTANT)
5155 : 7419 : continue;
5156 : :
5157 : 5483 : if (extremum == NULL)
5158 : : {
5159 : 3432 : extremum = arg;
5160 : 3432 : continue;
5161 : : }
5162 : :
5163 : 2051 : min_max_choose (arg->expr, extremum->expr, sign);
5164 : :
5165 : : /* Delete the extra constant argument. */
5166 : 2051 : last->next = arg->next;
5167 : :
5168 : 2051 : arg->next = NULL;
5169 : 2051 : gfc_free_actual_arglist (arg);
5170 : 2051 : arg = last;
5171 : : }
5172 : :
5173 : : /* If there is one value left, replace the function call with the
5174 : : expression. */
5175 : 5808 : if (expr->value.function.actual->next != NULL)
5176 : : return NULL;
5177 : :
5178 : : /* Handle special cases of specific functions (min|max)1 and
5179 : : a(min|max)0. */
5180 : :
5181 : 1670 : tmp = expr->value.function.actual->expr;
5182 : 1670 : fname = expr->value.function.isym->name;
5183 : :
5184 : 1670 : if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind)
5185 : 572 : && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0))
5186 : : {
5187 : : /* Explicit conversion, turn off -Wconversion and -Wconversion-extra
5188 : : warnings. */
5189 : 15 : tmp1 = warn_conversion;
5190 : 15 : tmp2 = warn_conversion_extra;
5191 : 15 : warn_conversion = warn_conversion_extra = 0;
5192 : :
5193 : 15 : ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind);
5194 : :
5195 : 15 : warn_conversion = tmp1;
5196 : 15 : warn_conversion_extra = tmp2;
5197 : : }
5198 : 1655 : else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind)
5199 : 1438 : && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0))
5200 : : {
5201 : 15 : ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind);
5202 : : }
5203 : : else
5204 : 1640 : ret = gfc_copy_expr (tmp);
5205 : :
5206 : : return ret;
5207 : :
5208 : : }
5209 : :
5210 : :
5211 : : gfc_expr *
5212 : 1841 : gfc_simplify_min (gfc_expr *e)
5213 : : {
5214 : 1841 : return simplify_min_max (e, -1);
5215 : : }
5216 : :
5217 : :
5218 : : gfc_expr *
5219 : 3967 : gfc_simplify_max (gfc_expr *e)
5220 : : {
5221 : 3967 : return simplify_min_max (e, 1);
5222 : : }
5223 : :
5224 : : /* Helper function for gfc_simplify_minval. */
5225 : :
5226 : : static gfc_expr *
5227 : 167 : gfc_min (gfc_expr *op1, gfc_expr *op2)
5228 : : {
5229 : 167 : min_max_choose (op1, op2, -1);
5230 : 167 : gfc_free_expr (op1);
5231 : 167 : return op2;
5232 : : }
5233 : :
5234 : : /* Simplify minval for constant arrays. */
5235 : :
5236 : : gfc_expr *
5237 : 3834 : gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5238 : : {
5239 : 3834 : return simplify_transformation (array, dim, mask, INT_MAX, gfc_min);
5240 : : }
5241 : :
5242 : : /* Helper function for gfc_simplify_maxval. */
5243 : :
5244 : : static gfc_expr *
5245 : 145 : gfc_max (gfc_expr *op1, gfc_expr *op2)
5246 : : {
5247 : 145 : min_max_choose (op1, op2, 1);
5248 : 145 : gfc_free_expr (op1);
5249 : 145 : return op2;
5250 : : }
5251 : :
5252 : :
5253 : : /* Simplify maxval for constant arrays. */
5254 : :
5255 : : gfc_expr *
5256 : 2716 : gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5257 : : {
5258 : 2716 : return simplify_transformation (array, dim, mask, INT_MIN, gfc_max);
5259 : : }
5260 : :
5261 : :
5262 : : /* Transform minloc or maxloc of an array, according to MASK,
5263 : : to the scalar result. This code is mostly identical to
5264 : : simplify_transformation_to_scalar. */
5265 : :
5266 : : static gfc_expr *
5267 : 58 : simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
5268 : : gfc_expr *extremum, int sign, bool back_val)
5269 : : {
5270 : 58 : gfc_expr *a, *m;
5271 : 58 : gfc_constructor *array_ctor, *mask_ctor;
5272 : 58 : mpz_t count;
5273 : :
5274 : 58 : mpz_set_si (result->value.integer, 0);
5275 : :
5276 : :
5277 : : /* Shortcut for constant .FALSE. MASK. */
5278 : 58 : if (mask
5279 : 42 : && mask->expr_type == EXPR_CONSTANT
5280 : 36 : && !mask->value.logical)
5281 : : return result;
5282 : :
5283 : 22 : array_ctor = gfc_constructor_first (array->value.constructor);
5284 : 22 : if (mask && mask->expr_type == EXPR_ARRAY)
5285 : 6 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5286 : : else
5287 : : mask_ctor = NULL;
5288 : :
5289 : 22 : mpz_init_set_si (count, 0);
5290 : 132 : while (array_ctor)
5291 : : {
5292 : 88 : mpz_add_ui (count, count, 1);
5293 : 88 : a = array_ctor->expr;
5294 : 88 : array_ctor = gfc_constructor_next (array_ctor);
5295 : : /* A constant MASK equals .TRUE. here and can be ignored. */
5296 : 88 : if (mask_ctor)
5297 : : {
5298 : 28 : m = mask_ctor->expr;
5299 : 28 : mask_ctor = gfc_constructor_next (mask_ctor);
5300 : 28 : if (!m->value.logical)
5301 : 12 : continue;
5302 : : }
5303 : 76 : if (min_max_choose (a, extremum, sign, back_val) > 0)
5304 : 36 : mpz_set (result->value.integer, count);
5305 : : }
5306 : 22 : mpz_clear (count);
5307 : 22 : gfc_free_expr (extremum);
5308 : 22 : return result;
5309 : : }
5310 : :
5311 : : /* Simplify minloc / maxloc in the absence of a dim argument. */
5312 : :
5313 : : static gfc_expr *
5314 : 69 : simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
5315 : : gfc_expr *array, gfc_expr *mask, int sign,
5316 : : bool back_val)
5317 : : {
5318 : 69 : ssize_t res[GFC_MAX_DIMENSIONS];
5319 : 69 : int i, n;
5320 : 69 : gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5321 : 69 : ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5322 : : sstride[GFC_MAX_DIMENSIONS];
5323 : 69 : gfc_expr *a, *m;
5324 : 69 : bool continue_loop;
5325 : 69 : bool ma;
5326 : :
5327 : 154 : for (i = 0; i<array->rank; i++)
5328 : 85 : res[i] = -1;
5329 : :
5330 : : /* Shortcut for constant .FALSE. MASK. */
5331 : 69 : if (mask
5332 : 56 : && mask->expr_type == EXPR_CONSTANT
5333 : 40 : && !mask->value.logical)
5334 : 38 : goto finish;
5335 : :
5336 : 31 : if (array->shape == NULL)
5337 : 1 : goto finish;
5338 : :
5339 : 66 : for (i = 0; i < array->rank; i++)
5340 : : {
5341 : 44 : count[i] = 0;
5342 : 44 : sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5343 : 44 : extent[i] = mpz_get_si (array->shape[i]);
5344 : 44 : if (extent[i] <= 0)
5345 : 8 : goto finish;
5346 : : }
5347 : :
5348 : 22 : continue_loop = true;
5349 : 22 : array_ctor = gfc_constructor_first (array->value.constructor);
5350 : 22 : if (mask && mask->rank > 0)
5351 : 12 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5352 : : else
5353 : : mask_ctor = NULL;
5354 : :
5355 : : /* Loop over the array elements (and mask), keeping track of
5356 : : the indices to return. */
5357 : 66 : while (continue_loop)
5358 : : {
5359 : 120 : do
5360 : : {
5361 : 120 : a = array_ctor->expr;
5362 : 120 : if (mask_ctor)
5363 : : {
5364 : 46 : m = mask_ctor->expr;
5365 : 46 : ma = m->value.logical;
5366 : 46 : mask_ctor = gfc_constructor_next (mask_ctor);
5367 : : }
5368 : : else
5369 : : ma = true;
5370 : :
5371 : 120 : if (ma && min_max_choose (a, extremum, sign, back_val) > 0)
5372 : : {
5373 : 130 : for (i = 0; i<array->rank; i++)
5374 : 86 : res[i] = count[i];
5375 : : }
5376 : 120 : array_ctor = gfc_constructor_next (array_ctor);
5377 : 120 : count[0] ++;
5378 : 120 : } while (count[0] != extent[0]);
5379 : : n = 0;
5380 : 58 : do
5381 : : {
5382 : : /* When we get to the end of a dimension, reset it and increment
5383 : : the next dimension. */
5384 : 58 : count[n] = 0;
5385 : 58 : n++;
5386 : 58 : if (n >= array->rank)
5387 : : {
5388 : : continue_loop = false;
5389 : : break;
5390 : : }
5391 : : else
5392 : 36 : count[n] ++;
5393 : 36 : } while (count[n] == extent[n]);
5394 : : }
5395 : :
5396 : 22 : finish:
5397 : 69 : gfc_free_expr (extremum);
5398 : 69 : result_ctor = gfc_constructor_first (result->value.constructor);
5399 : 154 : for (i = 0; i<array->rank; i++)
5400 : : {
5401 : 85 : gfc_expr *r_expr;
5402 : 85 : r_expr = result_ctor->expr;
5403 : 85 : mpz_set_si (r_expr->value.integer, res[i] + 1);
5404 : 85 : result_ctor = gfc_constructor_next (result_ctor);
5405 : : }
5406 : 69 : return result;
5407 : : }
5408 : :
5409 : : /* Helper function for gfc_simplify_minmaxloc - build an array
5410 : : expression with n elements. */
5411 : :
5412 : : static gfc_expr *
5413 : 86 : new_array (bt type, int kind, int n, locus *where)
5414 : : {
5415 : 86 : gfc_expr *result;
5416 : 86 : int i;
5417 : :
5418 : 86 : result = gfc_get_array_expr (type, kind, where);
5419 : 86 : result->rank = 1;
5420 : 86 : result->shape = gfc_get_shape(1);
5421 : 86 : mpz_init_set_si (result->shape[0], n);
5422 : 281 : for (i = 0; i < n; i++)
5423 : : {
5424 : 109 : gfc_constructor_append_expr (&result->value.constructor,
5425 : : gfc_get_constant_expr (type, kind, where),
5426 : : NULL);
5427 : : }
5428 : :
5429 : 86 : return result;
5430 : : }
5431 : :
5432 : : /* Simplify minloc and maxloc. This code is mostly identical to
5433 : : simplify_transformation_to_array. */
5434 : :
5435 : : static gfc_expr *
5436 : 24 : simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
5437 : : gfc_expr *dim, gfc_expr *mask,
5438 : : gfc_expr *extremum, int sign, bool back_val)
5439 : : {
5440 : 24 : mpz_t size;
5441 : 24 : int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5442 : 24 : gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5443 : 24 : gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5444 : :
5445 : 24 : int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5446 : : sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
5447 : : tmpstride[GFC_MAX_DIMENSIONS];
5448 : :
5449 : : /* Shortcut for constant .FALSE. MASK. */
5450 : 24 : if (mask
5451 : 10 : && mask->expr_type == EXPR_CONSTANT
5452 : 0 : && !mask->value.logical)
5453 : : return result;
5454 : :
5455 : : /* Build an indexed table for array element expressions to minimize
5456 : : linked-list traversal. Masked elements are set to NULL. */
5457 : 24 : gfc_array_size (array, &size);
5458 : 24 : arraysize = mpz_get_ui (size);
5459 : 24 : mpz_clear (size);
5460 : :
5461 : 24 : arrayvec = XCNEWVEC (gfc_expr*, arraysize);
5462 : :
5463 : 24 : array_ctor = gfc_constructor_first (array->value.constructor);
5464 : 24 : mask_ctor = NULL;
5465 : 24 : if (mask && mask->expr_type == EXPR_ARRAY)
5466 : 10 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5467 : :
5468 : 234 : for (i = 0; i < arraysize; ++i)
5469 : : {
5470 : 210 : arrayvec[i] = array_ctor->expr;
5471 : 210 : array_ctor = gfc_constructor_next (array_ctor);
5472 : :
5473 : 210 : if (mask_ctor)
5474 : : {
5475 : 106 : if (!mask_ctor->expr->value.logical)
5476 : 65 : arrayvec[i] = NULL;
5477 : :
5478 : 106 : mask_ctor = gfc_constructor_next (mask_ctor);
5479 : : }
5480 : : }
5481 : :
5482 : : /* Same for the result expression. */
5483 : 24 : gfc_array_size (result, &size);
5484 : 24 : resultsize = mpz_get_ui (size);
5485 : 24 : mpz_clear (size);
5486 : :
5487 : 24 : resultvec = XCNEWVEC (gfc_expr*, resultsize);
5488 : 24 : result_ctor = gfc_constructor_first (result->value.constructor);
5489 : 114 : for (i = 0; i < resultsize; ++i)
5490 : : {
5491 : 66 : resultvec[i] = result_ctor->expr;
5492 : 66 : result_ctor = gfc_constructor_next (result_ctor);
5493 : : }
5494 : :
5495 : 24 : gfc_extract_int (dim, &dim_index);
5496 : 24 : dim_index -= 1; /* zero-base index */
5497 : 24 : dim_extent = 0;
5498 : 24 : dim_stride = 0;
5499 : :
5500 : 72 : for (i = 0, n = 0; i < array->rank; ++i)
5501 : : {
5502 : 48 : count[i] = 0;
5503 : 48 : tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
5504 : 48 : if (i == dim_index)
5505 : : {
5506 : 24 : dim_extent = mpz_get_si (array->shape[i]);
5507 : 24 : dim_stride = tmpstride[i];
5508 : 24 : continue;
5509 : : }
5510 : :
5511 : 24 : extent[n] = mpz_get_si (array->shape[i]);
5512 : 24 : sstride[n] = tmpstride[i];
5513 : 24 : dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5514 : 24 : n += 1;
5515 : : }
5516 : :
5517 : 24 : done = resultsize <= 0;
5518 : 24 : base = arrayvec;
5519 : 24 : dest = resultvec;
5520 : 90 : while (!done)
5521 : : {
5522 : 66 : gfc_expr *ex;
5523 : 66 : ex = gfc_copy_expr (extremum);
5524 : 342 : for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5525 : : {
5526 : 210 : if (*src && min_max_choose (*src, ex, sign, back_val) > 0)
5527 : 107 : mpz_set_si ((*dest)->value.integer, n + 1);
5528 : : }
5529 : :
5530 : 66 : count[0]++;
5531 : 66 : base += sstride[0];
5532 : 66 : dest += dstride[0];
5533 : 66 : gfc_free_expr (ex);
5534 : :
5535 : 66 : n = 0;
5536 : 154 : while (!done && count[n] == extent[n])
5537 : : {
5538 : 22 : count[n] = 0;
5539 : 22 : base -= sstride[n] * extent[n];
5540 : 22 : dest -= dstride[n] * extent[n];
5541 : :
5542 : 22 : n++;
5543 : 22 : if (n < result->rank)
5544 : : {
5545 : : /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5546 : : times, we'd warn for the last iteration, because the
5547 : : array index will have already been incremented to the
5548 : : array sizes, and we can't tell that this must make
5549 : : the test against result->rank false, because ranks
5550 : : must not exceed GFC_MAX_DIMENSIONS. */
5551 : 0 : GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5552 : 0 : count[n]++;
5553 : 0 : base += sstride[n];
5554 : 0 : dest += dstride[n];
5555 : 0 : GCC_DIAGNOSTIC_POP
5556 : : }
5557 : : else
5558 : : done = true;
5559 : : }
5560 : : }
5561 : :
5562 : : /* Place updated expression in result constructor. */
5563 : 24 : result_ctor = gfc_constructor_first (result->value.constructor);
5564 : 114 : for (i = 0; i < resultsize; ++i)
5565 : : {
5566 : 66 : result_ctor->expr = resultvec[i];
5567 : 66 : result_ctor = gfc_constructor_next (result_ctor);
5568 : : }
5569 : :
5570 : 24 : free (arrayvec);
5571 : 24 : free (resultvec);
5572 : 24 : free (extremum);
5573 : 24 : return result;
5574 : : }
5575 : :
5576 : : /* Simplify minloc and maxloc for constant arrays. */
5577 : :
5578 : : static gfc_expr *
5579 : 8978 : gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
5580 : : gfc_expr *kind, gfc_expr *back, int sign)
5581 : : {
5582 : 8978 : gfc_expr *result;
5583 : 8978 : gfc_expr *extremum;
5584 : 8978 : int ikind;
5585 : 8978 : int init_val;
5586 : 8978 : bool back_val = false;
5587 : :
5588 : 8978 : if (!is_constant_array_expr (array)
5589 : 8978 : || !gfc_is_constant_expr (dim))
5590 : 8719 : return NULL;
5591 : :
5592 : 259 : if (mask
5593 : 216 : && !is_constant_array_expr (mask)
5594 : 443 : && mask->expr_type != EXPR_CONSTANT)
5595 : : return NULL;
5596 : :
5597 : 151 : if (kind)
5598 : : {
5599 : 0 : if (gfc_extract_int (kind, &ikind, -1))
5600 : : return NULL;
5601 : : }
5602 : : else
5603 : 151 : ikind = gfc_default_integer_kind;
5604 : :
5605 : 151 : if (back)
5606 : : {
5607 : 151 : if (back->expr_type != EXPR_CONSTANT)
5608 : : return NULL;
5609 : :
5610 : 151 : back_val = back->value.logical;
5611 : : }
5612 : :
5613 : 151 : if (sign < 0)
5614 : : init_val = INT_MAX;
5615 : 77 : else if (sign > 0)
5616 : : init_val = INT_MIN;
5617 : : else
5618 : 0 : gcc_unreachable();
5619 : :
5620 : 151 : extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
5621 : 151 : init_result_expr (extremum, init_val, array);
5622 : :
5623 : 151 : if (dim)
5624 : : {
5625 : 82 : result = transformational_result (array, dim, BT_INTEGER,
5626 : : ikind, &array->where);
5627 : 82 : init_result_expr (result, 0, array);
5628 : :
5629 : 82 : if (array->rank == 1)
5630 : 58 : return simplify_minmaxloc_to_scalar (result, array, mask, extremum,
5631 : 58 : sign, back_val);
5632 : : else
5633 : 24 : return simplify_minmaxloc_to_array (result, array, dim, mask, extremum,
5634 : 24 : sign, back_val);
5635 : : }
5636 : : else
5637 : : {
5638 : 69 : result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
5639 : 69 : return simplify_minmaxloc_nodim (result, extremum, array, mask,
5640 : 69 : sign, back_val);
5641 : : }
5642 : : }
5643 : :
5644 : : gfc_expr *
5645 : 5315 : gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5646 : : gfc_expr *back)
5647 : : {
5648 : 5315 : return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1);
5649 : : }
5650 : :
5651 : : gfc_expr *
5652 : 3663 : gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5653 : : gfc_expr *back)
5654 : : {
5655 : 3663 : return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
5656 : : }
5657 : :
5658 : : /* Simplify findloc to scalar. Similar to
5659 : : simplify_minmaxloc_to_scalar. */
5660 : :
5661 : : static gfc_expr *
5662 : 8 : simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5663 : : gfc_expr *mask, int back_val)
5664 : : {
5665 : 8 : gfc_expr *a, *m;
5666 : 8 : gfc_constructor *array_ctor, *mask_ctor;
5667 : 8 : mpz_t count;
5668 : :
5669 : 8 : mpz_set_si (result->value.integer, 0);
5670 : :
5671 : : /* Shortcut for constant .FALSE. MASK. */
5672 : 8 : if (mask
5673 : 2 : && mask->expr_type == EXPR_CONSTANT
5674 : 0 : && !mask->value.logical)
5675 : : return result;
5676 : :
5677 : 8 : array_ctor = gfc_constructor_first (array->value.constructor);
5678 : 8 : if (mask && mask->expr_type == EXPR_ARRAY)
5679 : 2 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5680 : : else
5681 : : mask_ctor = NULL;
5682 : :
5683 : 8 : mpz_init_set_si (count, 0);
5684 : 35 : while (array_ctor)
5685 : : {
5686 : 24 : mpz_add_ui (count, count, 1);
5687 : 24 : a = array_ctor->expr;
5688 : 24 : array_ctor = gfc_constructor_next (array_ctor);
5689 : : /* A constant MASK equals .TRUE. here and can be ignored. */
5690 : 24 : if (mask_ctor)
5691 : : {
5692 : 8 : m = mask_ctor->expr;
5693 : 8 : mask_ctor = gfc_constructor_next (mask_ctor);
5694 : 8 : if (!m->value.logical)
5695 : 2 : continue;
5696 : : }
5697 : 22 : if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5698 : : {
5699 : : /* We have a match. If BACK is true, continue so we find
5700 : : the last one. */
5701 : 8 : mpz_set (result->value.integer, count);
5702 : 8 : if (!back_val)
5703 : : break;
5704 : : }
5705 : : }
5706 : 8 : mpz_clear (count);
5707 : 8 : return result;
5708 : : }
5709 : :
5710 : : /* Simplify findloc in the absence of a dim argument. Similar to
5711 : : simplify_minmaxloc_nodim. */
5712 : :
5713 : : static gfc_expr *
5714 : 17 : simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
5715 : : gfc_expr *mask, bool back_val)
5716 : : {
5717 : 17 : ssize_t res[GFC_MAX_DIMENSIONS];
5718 : 17 : int i, n;
5719 : 17 : gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5720 : 17 : ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5721 : : sstride[GFC_MAX_DIMENSIONS];
5722 : 17 : gfc_expr *a, *m;
5723 : 17 : bool continue_loop;
5724 : 17 : bool ma;
5725 : :
5726 : 41 : for (i = 0; i < array->rank; i++)
5727 : 24 : res[i] = -1;
5728 : :
5729 : : /* Shortcut for constant .FALSE. MASK. */
5730 : 17 : if (mask
5731 : 1 : && mask->expr_type == EXPR_CONSTANT
5732 : 0 : && !mask->value.logical)
5733 : 0 : goto finish;
5734 : :
5735 : 35 : for (i = 0; i < array->rank; i++)
5736 : : {
5737 : 24 : count[i] = 0;
5738 : 24 : sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5739 : 24 : extent[i] = mpz_get_si (array->shape[i]);
5740 : 24 : if (extent[i] <= 0)
5741 : 6 : goto finish;
5742 : : }
5743 : :
5744 : 11 : continue_loop = true;
5745 : 11 : array_ctor = gfc_constructor_first (array->value.constructor);
5746 : 11 : if (mask && mask->rank > 0)
5747 : 1 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5748 : : else
5749 : : mask_ctor = NULL;
5750 : :
5751 : : /* Loop over the array elements (and mask), keeping track of
5752 : : the indices to return. */
5753 : 21 : while (continue_loop)
5754 : : {
5755 : 30 : do
5756 : : {
5757 : 30 : a = array_ctor->expr;
5758 : 30 : if (mask_ctor)
5759 : : {
5760 : 4 : m = mask_ctor->expr;
5761 : 4 : ma = m->value.logical;
5762 : 4 : mask_ctor = gfc_constructor_next (mask_ctor);
5763 : : }
5764 : : else
5765 : : ma = true;
5766 : :
5767 : 30 : if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5768 : : {
5769 : 19 : for (i = 0; i < array->rank; i++)
5770 : 12 : res[i] = count[i];
5771 : 7 : if (!back_val)
5772 : 5 : goto finish;
5773 : : }
5774 : 25 : array_ctor = gfc_constructor_next (array_ctor);
5775 : 25 : count[0] ++;
5776 : 25 : } while (count[0] != extent[0]);
5777 : : n = 0;
5778 : 13 : do
5779 : : {
5780 : : /* When we get to the end of a dimension, reset it and increment
5781 : : the next dimension. */
5782 : 13 : count[n] = 0;
5783 : 13 : n++;
5784 : 13 : if (n >= array->rank)
5785 : : {
5786 : : continue_loop = false;
5787 : : break;
5788 : : }
5789 : : else
5790 : 7 : count[n] ++;
5791 : 7 : } while (count[n] == extent[n]);
5792 : : }
5793 : :
5794 : 6 : finish:
5795 : 17 : result_ctor = gfc_constructor_first (result->value.constructor);
5796 : 41 : for (i = 0; i < array->rank; i++)
5797 : : {
5798 : 24 : gfc_expr *r_expr;
5799 : 24 : r_expr = result_ctor->expr;
5800 : 24 : mpz_set_si (r_expr->value.integer, res[i] + 1);
5801 : 24 : result_ctor = gfc_constructor_next (result_ctor);
5802 : : }
5803 : 17 : return result;
5804 : : }
5805 : :
5806 : :
5807 : : /* Simplify findloc to an array. Similar to
5808 : : simplify_minmaxloc_to_array. */
5809 : :
5810 : : static gfc_expr *
5811 : 2 : simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5812 : : gfc_expr *dim, gfc_expr *mask, bool back_val)
5813 : : {
5814 : 2 : mpz_t size;
5815 : 2 : int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5816 : 2 : gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5817 : 2 : gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5818 : :
5819 : 2 : int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5820 : : sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
5821 : : tmpstride[GFC_MAX_DIMENSIONS];
5822 : :
5823 : : /* Shortcut for constant .FALSE. MASK. */
5824 : 2 : if (mask
5825 : 0 : && mask->expr_type == EXPR_CONSTANT
5826 : 0 : && !mask->value.logical)
5827 : : return result;
5828 : :
5829 : : /* Build an indexed table for array element expressions to minimize
5830 : : linked-list traversal. Masked elements are set to NULL. */
5831 : 2 : gfc_array_size (array, &size);
5832 : 2 : arraysize = mpz_get_ui (size);
5833 : 2 : mpz_clear (size);
5834 : :
5835 : 2 : arrayvec = XCNEWVEC (gfc_expr*, arraysize);
5836 : :
5837 : 2 : array_ctor = gfc_constructor_first (array->value.constructor);
5838 : 2 : mask_ctor = NULL;
5839 : 2 : if (mask && mask->expr_type == EXPR_ARRAY)
5840 : 0 : mask_ctor = gfc_constructor_first (mask->value.constructor);
5841 : :
5842 : 14 : for (i = 0; i < arraysize; ++i)
5843 : : {
5844 : 12 : arrayvec[i] = array_ctor->expr;
5845 : 12 : array_ctor = gfc_constructor_next (array_ctor);
5846 : :
5847 : 12 : if (mask_ctor)
5848 : : {
5849 : 0 : if (!mask_ctor->expr->value.logical)
5850 : 0 : arrayvec[i] = NULL;
5851 : :
5852 : 0 : mask_ctor = gfc_constructor_next (mask_ctor);
5853 : : }
5854 : : }
5855 : :
5856 : : /* Same for the result expression. */
5857 : 2 : gfc_array_size (result, &size);
5858 : 2 : resultsize = mpz_get_ui (size);
5859 : 2 : mpz_clear (size);
5860 : :
5861 : 2 : resultvec = XCNEWVEC (gfc_expr*, resultsize);
5862 : 2 : result_ctor = gfc_constructor_first (result->value.constructor);
5863 : 9 : for (i = 0; i < resultsize; ++i)
5864 : : {
5865 : 5 : resultvec[i] = result_ctor->expr;
5866 : 5 : result_ctor = gfc_constructor_next (result_ctor);
5867 : : }
5868 : :
5869 : 2 : gfc_extract_int (dim, &dim_index);
5870 : :
5871 : 2 : dim_index -= 1; /* Zero-base index. */
5872 : 2 : dim_extent = 0;
5873 : 2 : dim_stride = 0;
5874 : :
5875 : 6 : for (i = 0, n = 0; i < array->rank; ++i)
5876 : : {
5877 : 4 : count[i] = 0;
5878 : 4 : tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
5879 : 4 : if (i == dim_index)
5880 : : {
5881 : 2 : dim_extent = mpz_get_si (array->shape[i]);
5882 : 2 : dim_stride = tmpstride[i];
5883 : 2 : continue;
5884 : : }
5885 : :
5886 : 2 : extent[n] = mpz_get_si (array->shape[i]);
5887 : 2 : sstride[n] = tmpstride[i];
5888 : 2 : dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5889 : 2 : n += 1;
5890 : : }
5891 : :
5892 : 2 : done = resultsize <= 0;
5893 : 2 : base = arrayvec;
5894 : 2 : dest = resultvec;
5895 : 7 : while (!done)
5896 : : {
5897 : 9 : for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5898 : : {
5899 : 8 : if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
5900 : : {
5901 : 4 : mpz_set_si ((*dest)->value.integer, n + 1);
5902 : 4 : if (!back_val)
5903 : : break;
5904 : : }
5905 : : }
5906 : :
5907 : 5 : count[0]++;
5908 : 5 : base += sstride[0];
5909 : 5 : dest += dstride[0];
5910 : :
5911 : 5 : n = 0;
5912 : 7 : while (!done && count[n] == extent[n])
5913 : : {
5914 : 2 : count[n] = 0;
5915 : 2 : base -= sstride[n] * extent[n];
5916 : 2 : dest -= dstride[n] * extent[n];
5917 : :
5918 : 2 : n++;
5919 : 2 : if (n < result->rank)
5920 : : {
5921 : : /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5922 : : times, we'd warn for the last iteration, because the
5923 : : array index will have already been incremented to the
5924 : : array sizes, and we can't tell that this must make
5925 : : the test against result->rank false, because ranks
5926 : : must not exceed GFC_MAX_DIMENSIONS. */
5927 : 0 : GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5928 : 0 : count[n]++;
5929 : 0 : base += sstride[n];
5930 : 0 : dest += dstride[n];
5931 : 0 : GCC_DIAGNOSTIC_POP
5932 : : }
5933 : : else
5934 : : done = true;
5935 : : }
5936 : : }
5937 : :
5938 : : /* Place updated expression in result constructor. */
5939 : 2 : result_ctor = gfc_constructor_first (result->value.constructor);
5940 : 9 : for (i = 0; i < resultsize; ++i)
5941 : : {
5942 : 5 : result_ctor->expr = resultvec[i];
5943 : 5 : result_ctor = gfc_constructor_next (result_ctor);
5944 : : }
5945 : :
5946 : 2 : free (arrayvec);
5947 : 2 : free (resultvec);
5948 : 2 : return result;
5949 : : }
5950 : :
5951 : : /* Simplify findloc. */
5952 : :
5953 : : gfc_expr *
5954 : 1032 : gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
5955 : : gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
5956 : : {
5957 : 1032 : gfc_expr *result;
5958 : 1032 : int ikind;
5959 : 1032 : bool back_val = false;
5960 : :
5961 : 1032 : if (!is_constant_array_expr (array)
5962 : 30 : || array->shape == NULL
5963 : 1061 : || !gfc_is_constant_expr (dim))
5964 : 1003 : return NULL;
5965 : :
5966 : 29 : if (! gfc_is_constant_expr (value))
5967 : : return 0;
5968 : :
5969 : 29 : if (mask
5970 : 3 : && !is_constant_array_expr (mask)
5971 : 29 : && mask->expr_type != EXPR_CONSTANT)
5972 : : return NULL;
5973 : :
5974 : 29 : if (kind)
5975 : : {
5976 : 0 : if (gfc_extract_int (kind, &ikind, -1))
5977 : : return NULL;
5978 : : }
5979 : : else
5980 : 29 : ikind = gfc_default_integer_kind;
5981 : :
5982 : 29 : if (back)
5983 : : {
5984 : 29 : if (back->expr_type != EXPR_CONSTANT)
5985 : : return NULL;
5986 : :
5987 : 27 : back_val = back->value.logical;
5988 : : }
5989 : :
5990 : 27 : if (dim)
5991 : : {
5992 : 10 : result = transformational_result (array, dim, BT_INTEGER,
5993 : : ikind, &array->where);
5994 : 10 : init_result_expr (result, 0, array);
5995 : :
5996 : 10 : if (array->rank == 1)
5997 : 8 : return simplify_findloc_to_scalar (result, array, value, mask,
5998 : 8 : back_val);
5999 : : else
6000 : 2 : return simplify_findloc_to_array (result, array, value, dim, mask,
6001 : 2 : back_val);
6002 : : }
6003 : : else
6004 : : {
6005 : 17 : result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
6006 : 17 : return simplify_findloc_nodim (result, value, array, mask, back_val);
6007 : : }
6008 : : return NULL;
6009 : : }
6010 : :
6011 : : gfc_expr *
6012 : 1 : gfc_simplify_maxexponent (gfc_expr *x)
6013 : : {
6014 : 1 : int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6015 : 1 : return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
6016 : 1 : gfc_real_kinds[i].max_exponent);
6017 : : }
6018 : :
6019 : :
6020 : : gfc_expr *
6021 : 25 : gfc_simplify_minexponent (gfc_expr *x)
6022 : : {
6023 : 25 : int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6024 : 25 : return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
6025 : 25 : gfc_real_kinds[i].min_exponent);
6026 : : }
6027 : :
6028 : :
6029 : : gfc_expr *
6030 : 266208 : gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
6031 : : {
6032 : 266208 : gfc_expr *result;
6033 : 266208 : int kind;
6034 : :
6035 : : /* First check p. */
6036 : 266208 : if (p->expr_type != EXPR_CONSTANT)
6037 : : return NULL;
6038 : :
6039 : : /* p shall not be 0. */
6040 : 265541 : switch (p->ts.type)
6041 : : {
6042 : 265433 : case BT_INTEGER:
6043 : 265433 : if (mpz_cmp_ui (p->value.integer, 0) == 0)
6044 : : {
6045 : 4 : gfc_error ("Argument %qs of MOD at %L shall not be zero",
6046 : : "P", &p->where);
6047 : 4 : return &gfc_bad_expr;
6048 : : }
6049 : : break;
6050 : 108 : case BT_REAL:
6051 : 108 : if (mpfr_cmp_ui (p->value.real, 0) == 0)
6052 : : {
6053 : 0 : gfc_error ("Argument %qs of MOD at %L shall not be zero",
6054 : : "P", &p->where);
6055 : 0 : return &gfc_bad_expr;
6056 : : }
6057 : : break;
6058 : 0 : default:
6059 : 0 : gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
6060 : : }
6061 : :
6062 : 265537 : if (a->expr_type != EXPR_CONSTANT)
6063 : : return NULL;
6064 : :
6065 : 262773 : kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6066 : 262773 : result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6067 : :
6068 : 262773 : if (a->ts.type == BT_INTEGER)
6069 : 262665 : mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
6070 : : else
6071 : : {
6072 : 108 : gfc_set_model_kind (kind);
6073 : 108 : mpfr_fmod (result->value.real, a->value.real, p->value.real,
6074 : : GFC_RND_MODE);
6075 : : }
6076 : :
6077 : 262773 : return range_check (result, "MOD");
6078 : : }
6079 : :
6080 : :
6081 : : gfc_expr *
6082 : 2020 : gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
6083 : : {
6084 : 2020 : gfc_expr *result;
6085 : 2020 : int kind;
6086 : :
6087 : : /* First check p. */
6088 : 2020 : if (p->expr_type != EXPR_CONSTANT)
6089 : : return NULL;
6090 : :
6091 : : /* p shall not be 0. */
6092 : 1865 : switch (p->ts.type)
6093 : : {
6094 : 1829 : case BT_INTEGER:
6095 : 1829 : if (mpz_cmp_ui (p->value.integer, 0) == 0)
6096 : : {
6097 : 4 : gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6098 : : "P", &p->where);
6099 : 4 : return &gfc_bad_expr;
6100 : : }
6101 : : break;
6102 : 36 : case BT_REAL:
6103 : 36 : if (mpfr_cmp_ui (p->value.real, 0) == 0)
6104 : : {
6105 : 0 : gfc_error ("Argument %qs of MODULO at %L shall not be zero",
6106 : : "P", &p->where);
6107 : 0 : return &gfc_bad_expr;
6108 : : }
6109 : : break;
6110 : 0 : default:
6111 : 0 : gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
6112 : : }
6113 : :
6114 : 1861 : if (a->expr_type != EXPR_CONSTANT)
6115 : : return NULL;
6116 : :
6117 : 234 : kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
6118 : 234 : result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
6119 : :
6120 : 234 : if (a->ts.type == BT_INTEGER)
6121 : 198 : mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
6122 : : else
6123 : : {
6124 : 36 : gfc_set_model_kind (kind);
6125 : 36 : mpfr_fmod (result->value.real, a->value.real, p->value.real,
6126 : : GFC_RND_MODE);
6127 : 36 : if (mpfr_cmp_ui (result->value.real, 0) != 0)
6128 : : {
6129 : 12 : if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
6130 : 6 : mpfr_add (result->value.real, result->value.real, p->value.real,
6131 : : GFC_RND_MODE);
6132 : : }
6133 : : else
6134 : 24 : mpfr_copysign (result->value.real, result->value.real,
6135 : : p->value.real, GFC_RND_MODE);
6136 : : }
6137 : :
6138 : 234 : return range_check (result, "MODULO");
6139 : : }
6140 : :
6141 : :
6142 : : gfc_expr *
6143 : 6320 : gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
6144 : : {
6145 : 6320 : gfc_expr *result;
6146 : 6320 : mpfr_exp_t emin, emax;
6147 : 6320 : int kind;
6148 : :
6149 : 6320 : if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
6150 : : return NULL;
6151 : :
6152 : 826 : result = gfc_copy_expr (x);
6153 : :
6154 : : /* Save current values of emin and emax. */
6155 : 826 : emin = mpfr_get_emin ();
6156 : 826 : emax = mpfr_get_emax ();
6157 : :
6158 : : /* Set emin and emax for the current model number. */
6159 : 826 : kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
6160 : 826 : mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent -
6161 : 826 : mpfr_get_prec(result->value.real) + 1);
6162 : 826 : mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent);
6163 : 826 : mpfr_check_range (result->value.real, 0, MPFR_RNDU);
6164 : :
6165 : 826 : if (mpfr_sgn (s->value.real) > 0)
6166 : : {
6167 : 404 : mpfr_nextabove (result->value.real);
6168 : 404 : mpfr_subnormalize (result->value.real, 0, MPFR_RNDU);
6169 : : }
6170 : : else
6171 : : {
6172 : 422 : mpfr_nextbelow (result->value.real);
6173 : 422 : mpfr_subnormalize (result->value.real, 0, MPFR_RNDD);
6174 : : }
6175 : :
6176 : 826 : mpfr_set_emin (emin);
6177 : 826 : mpfr_set_emax (emax);
6178 : :
6179 : : /* Only NaN can occur. Do not use range check as it gives an
6180 : : error for denormal numbers. */
6181 : 826 : if (mpfr_nan_p (result->value.real) && flag_range_check)
6182 : : {
6183 : 0 : gfc_error ("Result of NEAREST is NaN at %L", &result->where);
6184 : 0 : gfc_free_expr (result);
6185 : 0 : return &gfc_bad_expr;
6186 : : }
6187 : :
6188 : : return result;
6189 : : }
6190 : :
6191 : :
6192 : : static gfc_expr *
6193 : 508 : simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
6194 : : {
6195 : 508 : gfc_expr *itrunc, *result;
6196 : 508 : int kind;
6197 : :
6198 : 508 : kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
6199 : 508 : if (kind == -1)
6200 : : return &gfc_bad_expr;
6201 : :
6202 : 508 : if (e->expr_type != EXPR_CONSTANT)
6203 : : return NULL;
6204 : :
6205 : 156 : itrunc = gfc_copy_expr (e);
6206 : 156 : mpfr_round (itrunc->value.real, e->value.real);
6207 : :
6208 : 156 : result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
6209 : 156 : gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
6210 : :
6211 : 156 : gfc_free_expr (itrunc);
6212 : :
6213 : 156 : return range_check (result, name);
6214 : : }
6215 : :
6216 : :
6217 : : gfc_expr *
6218 : 325 : gfc_simplify_new_line (gfc_expr *e)
6219 : : {
6220 : 325 : gfc_expr *result;
6221 : :
6222 : 325 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
6223 : 325 : result->value.character.string[0] = '\n';
6224 : :
6225 : 325 : return result;
6226 : : }
6227 : :
6228 : :
6229 : : gfc_expr *
6230 : 376 : gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
6231 : : {
6232 : 376 : return simplify_nint ("NINT", e, k);
6233 : : }
6234 : :
6235 : :
6236 : : gfc_expr *
6237 : 132 : gfc_simplify_idnint (gfc_expr *e)
6238 : : {
6239 : 132 : return simplify_nint ("IDNINT", e, NULL);
6240 : : }
6241 : :
6242 : : static int norm2_scale;
6243 : :
6244 : : static gfc_expr *
6245 : 124 : norm2_add_squared (gfc_expr *result, gfc_expr *e)
6246 : : {
6247 : 124 : mpfr_t tmp;
6248 : :
6249 : 124 : gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6250 : 124 : gcc_assert (result->ts.type == BT_REAL
6251 : : && result->expr_type == EXPR_CONSTANT);
6252 : :
6253 : 124 : gfc_set_model_kind (result->ts.kind);
6254 : 124 : int index = gfc_validate_kind (BT_REAL, result->ts.kind, false);
6255 : 124 : mpfr_exp_t exp;
6256 : 124 : if (mpfr_regular_p (result->value.real))
6257 : : {
6258 : 61 : exp = mpfr_get_exp (result->value.real);
6259 : : /* If result is getting close to overflowing, scale down. */
6260 : 61 : if (exp >= gfc_real_kinds[index].max_exponent - 4
6261 : 0 : && norm2_scale <= gfc_real_kinds[index].max_exponent - 2)
6262 : : {
6263 : 0 : norm2_scale += 2;
6264 : 0 : mpfr_div_ui (result->value.real, result->value.real, 16,
6265 : : GFC_RND_MODE);
6266 : : }
6267 : : }
6268 : :
6269 : 124 : mpfr_init (tmp);
6270 : 124 : if (mpfr_regular_p (e->value.real))
6271 : : {
6272 : 88 : exp = mpfr_get_exp (e->value.real);
6273 : : /* If e**2 would overflow or close to overflowing, scale down. */
6274 : 88 : if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2)
6275 : : {
6276 : 12 : int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4;
6277 : 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6278 : 12 : mpfr_set_exp (tmp, new_scale - norm2_scale);
6279 : 12 : mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6280 : 12 : mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6281 : 12 : norm2_scale = new_scale;
6282 : : }
6283 : : }
6284 : 124 : if (norm2_scale)
6285 : : {
6286 : 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6287 : 12 : mpfr_set_exp (tmp, norm2_scale);
6288 : 12 : mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE);
6289 : : }
6290 : : else
6291 : 112 : mpfr_set (tmp, e->value.real, GFC_RND_MODE);
6292 : 124 : mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE);
6293 : 124 : mpfr_add (result->value.real, result->value.real, tmp,
6294 : : GFC_RND_MODE);
6295 : 124 : mpfr_clear (tmp);
6296 : :
6297 : 124 : return result;
6298 : : }
6299 : :
6300 : :
6301 : : static gfc_expr *
6302 : 2 : norm2_do_sqrt (gfc_expr *result, gfc_expr *e)
6303 : : {
6304 : 2 : gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6305 : 2 : gcc_assert (result->ts.type == BT_REAL
6306 : : && result->expr_type == EXPR_CONSTANT);
6307 : :
6308 : 2 : if (result != e)
6309 : 0 : mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
6310 : 2 : mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6311 : 2 : if (norm2_scale && mpfr_regular_p (result->value.real))
6312 : : {
6313 : 0 : mpfr_t tmp;
6314 : 0 : mpfr_init (tmp);
6315 : 0 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6316 : 0 : mpfr_set_exp (tmp, norm2_scale);
6317 : 0 : mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6318 : 0 : mpfr_clear (tmp);
6319 : : }
6320 : 2 : norm2_scale = 0;
6321 : :
6322 : 2 : return result;
6323 : : }
6324 : :
6325 : :
6326 : : gfc_expr *
6327 : 449 : gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
6328 : : {
6329 : 449 : gfc_expr *result;
6330 : 449 : bool size_zero;
6331 : :
6332 : 449 : size_zero = gfc_is_size_zero_array (e);
6333 : :
6334 : 835 : if (!(is_constant_array_expr (e) || size_zero)
6335 : 449 : || (dim != NULL && !gfc_is_constant_expr (dim)))
6336 : 386 : return NULL;
6337 : :
6338 : 63 : result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
6339 : 63 : init_result_expr (result, 0, NULL);
6340 : :
6341 : 63 : if (size_zero)
6342 : : return result;
6343 : :
6344 : 38 : norm2_scale = 0;
6345 : 38 : if (!dim || e->rank == 1)
6346 : : {
6347 : 37 : result = simplify_transformation_to_scalar (result, e, NULL,
6348 : : norm2_add_squared);
6349 : 37 : mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6350 : 37 : if (norm2_scale && mpfr_regular_p (result->value.real))
6351 : : {
6352 : 12 : mpfr_t tmp;
6353 : 12 : mpfr_init (tmp);
6354 : 12 : mpfr_set_ui (tmp, 1, GFC_RND_MODE);
6355 : 12 : mpfr_set_exp (tmp, norm2_scale);
6356 : 12 : mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
6357 : 12 : mpfr_clear (tmp);
6358 : : }
6359 : 37 : norm2_scale = 0;
6360 : 37 : }
6361 : : else
6362 : 1 : result = simplify_transformation_to_array (result, e, dim, NULL,
6363 : : norm2_add_squared,
6364 : : norm2_do_sqrt);
6365 : :
6366 : : return result;
6367 : : }
6368 : :
6369 : :
6370 : : gfc_expr *
6371 : 572 : gfc_simplify_not (gfc_expr *e)
6372 : : {
6373 : 572 : gfc_expr *result;
6374 : :
6375 : 572 : if (e->expr_type != EXPR_CONSTANT)
6376 : : return NULL;
6377 : :
6378 : 198 : result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6379 : 198 : mpz_com (result->value.integer, e->value.integer);
6380 : :
6381 : 198 : return range_check (result, "NOT");
6382 : : }
6383 : :
6384 : :
6385 : : gfc_expr *
6386 : 1235 : gfc_simplify_null (gfc_expr *mold)
6387 : : {
6388 : 1235 : gfc_expr *result;
6389 : :
6390 : 1235 : if (mold)
6391 : : {
6392 : 96 : result = gfc_copy_expr (mold);
6393 : 96 : result->expr_type = EXPR_NULL;
6394 : : }
6395 : : else
6396 : 1139 : result = gfc_get_null_expr (NULL);
6397 : :
6398 : 1235 : return result;
6399 : : }
6400 : :
6401 : :
6402 : : gfc_expr *
6403 : 1160 : gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
6404 : : {
6405 : 1160 : gfc_expr *result;
6406 : :
6407 : 1160 : if (flag_coarray == GFC_FCOARRAY_NONE)
6408 : : {
6409 : 0 : gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6410 : : return &gfc_bad_expr;
6411 : : }
6412 : :
6413 : 1160 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
6414 : : return NULL;
6415 : :
6416 : 377 : if (failed && failed->expr_type != EXPR_CONSTANT)
6417 : : return NULL;
6418 : :
6419 : : /* FIXME: gfc_current_locus is wrong. */
6420 : 377 : result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6421 : : &gfc_current_locus);
6422 : :
6423 : 377 : if (failed && failed->value.logical != 0)
6424 : 1 : mpz_set_si (result->value.integer, 0);
6425 : : else
6426 : 376 : mpz_set_si (result->value.integer, 1);
6427 : :
6428 : : return result;
6429 : : }
6430 : :
6431 : :
6432 : : gfc_expr *
6433 : 20 : gfc_simplify_or (gfc_expr *x, gfc_expr *y)
6434 : : {
6435 : 20 : gfc_expr *result;
6436 : 20 : int kind;
6437 : :
6438 : 20 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6439 : : return NULL;
6440 : :
6441 : 6 : kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6442 : :
6443 : 6 : switch (x->ts.type)
6444 : : {
6445 : 0 : case BT_INTEGER:
6446 : 0 : result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6447 : 0 : mpz_ior (result->value.integer, x->value.integer, y->value.integer);
6448 : 0 : return range_check (result, "OR");
6449 : :
6450 : 6 : case BT_LOGICAL:
6451 : 6 : return gfc_get_logical_expr (kind, &x->where,
6452 : 12 : x->value.logical || y->value.logical);
6453 : 0 : default:
6454 : 0 : gcc_unreachable();
6455 : : }
6456 : : }
6457 : :
6458 : :
6459 : : gfc_expr *
6460 : 975 : gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
6461 : : {
6462 : 975 : gfc_expr *result;
6463 : 975 : gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
6464 : :
6465 : 975 : if (!is_constant_array_expr (array)
6466 : 58 : || !is_constant_array_expr (vector)
6467 : 1033 : || (!gfc_is_constant_expr (mask)
6468 : 2 : && !is_constant_array_expr (mask)))
6469 : 918 : return NULL;
6470 : :
6471 : 57 : result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
6472 : 57 : if (array->ts.type == BT_DERIVED)
6473 : 5 : result->ts.u.derived = array->ts.u.derived;
6474 : :
6475 : 57 : array_ctor = gfc_constructor_first (array->value.constructor);
6476 : 114 : vector_ctor = vector
6477 : 57 : ? gfc_constructor_first (vector->value.constructor)
6478 : : : NULL;
6479 : :
6480 : 57 : if (mask->expr_type == EXPR_CONSTANT
6481 : 0 : && mask->value.logical)
6482 : : {
6483 : : /* Copy all elements of ARRAY to RESULT. */
6484 : 0 : while (array_ctor)
6485 : : {
6486 : 0 : gfc_constructor_append_expr (&result->value.constructor,
6487 : : gfc_copy_expr (array_ctor->expr),
6488 : : NULL);
6489 : :
6490 : 0 : array_ctor = gfc_constructor_next (array_ctor);
6491 : 0 : vector_ctor = gfc_constructor_next (vector_ctor);
6492 : : }
6493 : : }
6494 : 57 : else if (mask->expr_type == EXPR_ARRAY)
6495 : : {
6496 : : /* Copy only those elements of ARRAY to RESULT whose
6497 : : MASK equals .TRUE.. */
6498 : 57 : mask_ctor = gfc_constructor_first (mask->value.constructor);
6499 : 303 : while (mask_ctor && array_ctor)
6500 : : {
6501 : 189 : if (mask_ctor->expr->value.logical)
6502 : : {
6503 : 130 : gfc_constructor_append_expr (&result->value.constructor,
6504 : : gfc_copy_expr (array_ctor->expr),
6505 : : NULL);
6506 : 130 : vector_ctor = gfc_constructor_next (vector_ctor);
6507 : : }
6508 : :
6509 : 189 : array_ctor = gfc_constructor_next (array_ctor);
6510 : 189 : mask_ctor = gfc_constructor_next (mask_ctor);
6511 : : }
6512 : : }
6513 : :
6514 : : /* Append any left-over elements from VECTOR to RESULT. */
6515 : 85 : while (vector_ctor)
6516 : : {
6517 : 28 : gfc_constructor_append_expr (&result->value.constructor,
6518 : : gfc_copy_expr (vector_ctor->expr),
6519 : : NULL);
6520 : 28 : vector_ctor = gfc_constructor_next (vector_ctor);
6521 : : }
6522 : :
6523 : 57 : result->shape = gfc_get_shape (1);
6524 : 57 : gfc_array_size (result, &result->shape[0]);
6525 : :
6526 : 57 : if (array->ts.type == BT_CHARACTER)
6527 : 51 : result->ts.u.cl = array->ts.u.cl;
6528 : :
6529 : : return result;
6530 : : }
6531 : :
6532 : :
6533 : : static gfc_expr *
6534 : 124 : do_xor (gfc_expr *result, gfc_expr *e)
6535 : : {
6536 : 124 : gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
6537 : 124 : gcc_assert (result->ts.type == BT_LOGICAL
6538 : : && result->expr_type == EXPR_CONSTANT);
6539 : :
6540 : 124 : result->value.logical = result->value.logical != e->value.logical;
6541 : 124 : return result;
6542 : : }
6543 : :
6544 : :
6545 : : gfc_expr *
6546 : 859 : gfc_simplify_is_contiguous (gfc_expr *array)
6547 : : {
6548 : 859 : if (gfc_is_simply_contiguous (array, false, true))
6549 : 26 : return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);
6550 : :
6551 : 833 : if (gfc_is_not_contiguous (array))
6552 : 6 : return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
6553 : :
6554 : : return NULL;
6555 : : }
6556 : :
6557 : :
6558 : : gfc_expr *
6559 : 147 : gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
6560 : : {
6561 : 147 : return simplify_transformation (e, dim, NULL, 0, do_xor);
6562 : : }
6563 : :
6564 : :
6565 : : gfc_expr *
6566 : 1064 : gfc_simplify_popcnt (gfc_expr *e)
6567 : : {
6568 : 1064 : int res, k;
6569 : 1064 : mpz_t x;
6570 : :
6571 : 1064 : if (e->expr_type != EXPR_CONSTANT)
6572 : : return NULL;
6573 : :
6574 : 642 : k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6575 : :
6576 : : /* Convert argument to unsigned, then count the '1' bits. */
6577 : 642 : mpz_init_set (x, e->value.integer);
6578 : 642 : convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
6579 : 642 : res = mpz_popcount (x);
6580 : 642 : mpz_clear (x);
6581 : :
6582 : 642 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
6583 : : }
6584 : :
6585 : :
6586 : : gfc_expr *
6587 : 362 : gfc_simplify_poppar (gfc_expr *e)
6588 : : {
6589 : 362 : gfc_expr *popcnt;
6590 : 362 : int i;
6591 : :
6592 : 362 : if (e->expr_type != EXPR_CONSTANT)
6593 : : return NULL;
6594 : :
6595 : 300 : popcnt = gfc_simplify_popcnt (e);
6596 : 300 : gcc_assert (popcnt);
6597 : :
6598 : 300 : bool fail = gfc_extract_int (popcnt, &i);
6599 : 300 : gcc_assert (!fail);
6600 : :
6601 : 300 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
6602 : : }
6603 : :
6604 : :
6605 : : gfc_expr *
6606 : 460 : gfc_simplify_precision (gfc_expr *e)
6607 : : {
6608 : 460 : int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6609 : 460 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
6610 : 460 : gfc_real_kinds[i].precision);
6611 : : }
6612 : :
6613 : :
6614 : : gfc_expr *
6615 : 801 : gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
6616 : : {
6617 : 801 : return simplify_transformation (array, dim, mask, 1, gfc_multiply);
6618 : : }
6619 : :
6620 : :
6621 : : gfc_expr *
6622 : 49 : gfc_simplify_radix (gfc_expr *e)
6623 : : {
6624 : 49 : int i;
6625 : 49 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6626 : :
6627 : 49 : switch (e->ts.type)
6628 : : {
6629 : 0 : case BT_INTEGER:
6630 : 0 : i = gfc_integer_kinds[i].radix;
6631 : 0 : break;
6632 : :
6633 : 49 : case BT_REAL:
6634 : 49 : i = gfc_real_kinds[i].radix;
6635 : 49 : break;
6636 : :
6637 : 0 : default:
6638 : 0 : gcc_unreachable ();
6639 : : }
6640 : :
6641 : 49 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6642 : : }
6643 : :
6644 : :
6645 : : gfc_expr *
6646 : 141 : gfc_simplify_range (gfc_expr *e)
6647 : : {
6648 : 141 : int i;
6649 : 141 : i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6650 : :
6651 : 141 : switch (e->ts.type)
6652 : : {
6653 : 70 : case BT_INTEGER:
6654 : 70 : i = gfc_integer_kinds[i].range;
6655 : 70 : break;
6656 : :
6657 : 71 : case BT_REAL:
6658 : 71 : case BT_COMPLEX:
6659 : 71 : i = gfc_real_kinds[i].range;
6660 : 71 : break;
6661 : :
6662 : 0 : default:
6663 : 0 : gcc_unreachable ();
6664 : : }
6665 : :
6666 : 141 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6667 : : }
6668 : :
6669 : :
6670 : : gfc_expr *
6671 : 2016 : gfc_simplify_rank (gfc_expr *e)
6672 : : {
6673 : : /* Assumed rank. */
6674 : 2016 : if (e->rank == -1)
6675 : : return NULL;
6676 : :
6677 : 590 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
6678 : : }
6679 : :
6680 : :
6681 : : gfc_expr *
6682 : 27334 : gfc_simplify_real (gfc_expr *e, gfc_expr *k)
6683 : : {
6684 : 27334 : gfc_expr *result = NULL;
6685 : 27334 : int kind, tmp1, tmp2;
6686 : :
6687 : : /* Convert BOZ to real, and return without range checking. */
6688 : 27334 : if (e->ts.type == BT_BOZ)
6689 : : {
6690 : : /* Determine kind for conversion of the BOZ. */
6691 : 82 : if (k)
6692 : 63 : gfc_extract_int (k, &kind);
6693 : : else
6694 : 19 : kind = gfc_default_real_kind;
6695 : :
6696 : 82 : if (!gfc_boz2real (e, kind))
6697 : : return NULL;
6698 : 82 : result = gfc_copy_expr (e);
6699 : 82 : return result;
6700 : : }
6701 : :
6702 : 27252 : if (e->ts.type == BT_COMPLEX)
6703 : 2018 : kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
6704 : : else
6705 : 25234 : kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
6706 : :
6707 : 27252 : if (kind == -1)
6708 : : return &gfc_bad_expr;
6709 : :
6710 : 27252 : if (e->expr_type != EXPR_CONSTANT)
6711 : : return NULL;
6712 : :
6713 : : /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
6714 : : warnings. */
6715 : 21783 : tmp1 = warn_conversion;
6716 : 21783 : tmp2 = warn_conversion_extra;
6717 : 21783 : warn_conversion = warn_conversion_extra = 0;
6718 : :
6719 : 21783 : result = gfc_convert_constant (e, BT_REAL, kind);
6720 : :
6721 : 21783 : warn_conversion = tmp1;
6722 : 21783 : warn_conversion_extra = tmp2;
6723 : :
6724 : 21783 : if (result == &gfc_bad_expr)
6725 : : return &gfc_bad_expr;
6726 : :
6727 : 21782 : return range_check (result, "REAL");
6728 : : }
6729 : :
6730 : :
6731 : : gfc_expr *
6732 : 7 : gfc_simplify_realpart (gfc_expr *e)
6733 : : {
6734 : 7 : gfc_expr *result;
6735 : :
6736 : 7 : if (e->expr_type != EXPR_CONSTANT)
6737 : : return NULL;
6738 : :
6739 : 1 : result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
6740 : 1 : mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
6741 : :
6742 : 1 : return range_check (result, "REALPART");
6743 : : }
6744 : :
6745 : : gfc_expr *
6746 : 2565 : gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
6747 : : {
6748 : 2565 : gfc_expr *result;
6749 : 2565 : gfc_charlen_t len;
6750 : 2565 : mpz_t ncopies;
6751 : 2565 : bool have_length = false;
6752 : :
6753 : : /* If NCOPIES isn't a constant, there's nothing we can do. */
6754 : 2565 : if (n->expr_type != EXPR_CONSTANT)
6755 : : return NULL;
6756 : :
6757 : : /* If NCOPIES is negative, it's an error. */
6758 : 2053 : if (mpz_sgn (n->value.integer) < 0)
6759 : : {
6760 : 6 : gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6761 : : &n->where);
6762 : 6 : return &gfc_bad_expr;
6763 : : }
6764 : :
6765 : : /* If we don't know the character length, we can do no more. */
6766 : 2047 : if (e->ts.u.cl && e->ts.u.cl->length
6767 : 404 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6768 : : {
6769 : 404 : len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer);
6770 : 404 : have_length = true;
6771 : : }
6772 : 1643 : else if (e->expr_type == EXPR_CONSTANT
6773 : 1643 : && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
6774 : : {
6775 : 1643 : len = e->value.character.length;
6776 : : }
6777 : : else
6778 : : return NULL;
6779 : :
6780 : : /* If the source length is 0, any value of NCOPIES is valid
6781 : : and everything behaves as if NCOPIES == 0. */
6782 : 2047 : mpz_init (ncopies);
6783 : 2047 : if (len == 0)
6784 : 63 : mpz_set_ui (ncopies, 0);
6785 : : else
6786 : 1984 : mpz_set (ncopies, n->value.integer);
6787 : :
6788 : : /* Check that NCOPIES isn't too large. */
6789 : 2047 : if (len)
6790 : : {
6791 : 1984 : mpz_t max, mlen;
6792 : 1984 : int i;
6793 : :
6794 : : /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6795 : 1984 : mpz_init (max);
6796 : 1984 : i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
6797 : :
6798 : 1984 : if (have_length)
6799 : : {
6800 : 347 : mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
6801 : 347 : e->ts.u.cl->length->value.integer);
6802 : : }
6803 : : else
6804 : : {
6805 : 1637 : mpz_init (mlen);
6806 : 1637 : gfc_mpz_set_hwi (mlen, len);
6807 : 1637 : mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
6808 : 1637 : mpz_clear (mlen);
6809 : : }
6810 : :
6811 : : /* The check itself. */
6812 : 1984 : if (mpz_cmp (ncopies, max) > 0)
6813 : : {
6814 : 4 : mpz_clear (max);
6815 : 4 : mpz_clear (ncopies);
6816 : 4 : gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6817 : : &n->where);
6818 : 4 : return &gfc_bad_expr;
6819 : : }
6820 : :
6821 : 1980 : mpz_clear (max);
6822 : : }
6823 : 2043 : mpz_clear (ncopies);
6824 : :
6825 : : /* For further simplification, we need the character string to be
6826 : : constant. */
6827 : 2043 : if (e->expr_type != EXPR_CONSTANT)
6828 : : return NULL;
6829 : :
6830 : 1698 : HOST_WIDE_INT ncop;
6831 : 1698 : if (len ||
6832 : 42 : (e->ts.u.cl->length &&
6833 : 18 : mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
6834 : : {
6835 : 1674 : bool fail = gfc_extract_hwi (n, &ncop);
6836 : 1674 : gcc_assert (!fail);
6837 : : }
6838 : : else
6839 : 24 : ncop = 0;
6840 : :
6841 : 1698 : if (ncop == 0)
6842 : 54 : return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
6843 : :
6844 : 1644 : len = e->value.character.length;
6845 : 1644 : gfc_charlen_t nlen = ncop * len;
6846 : :
6847 : : /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6848 : : (2**28 elements * 4 bytes (wide chars) per element) defer to
6849 : : runtime instead of consuming (unbounded) memory and CPU at
6850 : : compile time. */
6851 : 1644 : if (nlen > 268435456)
6852 : : {
6853 : 1 : gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6854 : : " deferred to runtime, expect bugs", &e->where);
6855 : 1 : return NULL;
6856 : : }
6857 : :
6858 : 1643 : result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
6859 : 58618 : for (size_t i = 0; i < (size_t) ncop; i++)
6860 : 114280 : for (size_t j = 0; j < (size_t) len; j++)
6861 : 57305 : result->value.character.string[j+i*len]= e->value.character.string[j];
6862 : :
6863 : 1643 : result->value.character.string[nlen] = '\0'; /* For debugger */
6864 : 1643 : return result;
6865 : : }
6866 : :
6867 : :
6868 : : /* This one is a bear, but mainly has to do with shuffling elements. */
6869 : :
6870 : : gfc_expr *
6871 : 5240 : gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
6872 : : gfc_expr *pad, gfc_expr *order_exp)
6873 : : {
6874 : 5240 : int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
6875 : 5240 : int i, rank, npad, x[GFC_MAX_DIMENSIONS];
6876 : 5240 : mpz_t index, size;
6877 : 5240 : unsigned long j;
6878 : 5240 : size_t nsource;
6879 : 5240 : gfc_expr *e, *result;
6880 : 5240 : bool zerosize = false;
6881 : :
6882 : : /* Check that argument expression types are OK. */
6883 : 5240 : if (!is_constant_array_expr (source)
6884 : 3658 : || !is_constant_array_expr (shape_exp)
6885 : 3630 : || !is_constant_array_expr (pad)
6886 : 8870 : || !is_constant_array_expr (order_exp))
6887 : 1622 : return NULL;
6888 : :
6889 : 3618 : if (source->shape == NULL)
6890 : : return NULL;
6891 : :
6892 : : /* Proceed with simplification, unpacking the array. */
6893 : :
6894 : 3615 : mpz_init (index);
6895 : 3615 : rank = 0;
6896 : :
6897 : 61455 : for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
6898 : 54225 : x[i] = 0;
6899 : :
6900 : 18455 : for (;;)
6901 : : {
6902 : 11035 : e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
6903 : 11035 : if (e == NULL)
6904 : : break;
6905 : :
6906 : 7420 : gfc_extract_int (e, &shape[rank]);
6907 : :
6908 : 7420 : gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
6909 : 7420 : if (shape[rank] < 0)
6910 : : {
6911 : 0 : gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
6912 : : "negative value %d for dimension %d",
6913 : : &shape_exp->where, shape[rank], rank+1);
6914 : 0 : mpz_clear (index);
6915 : 0 : return &gfc_bad_expr;
6916 : : }
6917 : :
6918 : 7420 : rank++;
6919 : : }
6920 : :
6921 : 3615 : gcc_assert (rank > 0);
6922 : :
6923 : : /* Now unpack the order array if present. */
6924 : 3615 : if (order_exp == NULL)
6925 : : {
6926 : 10969 : for (i = 0; i < rank; i++)
6927 : 7376 : order[i] = i;
6928 : : }
6929 : : else
6930 : : {
6931 : 22 : mpz_t size;
6932 : 22 : int order_size, shape_size;
6933 : :
6934 : 22 : if (order_exp->rank != shape_exp->rank)
6935 : : {
6936 : 1 : gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
6937 : : &order_exp->where, &shape_exp->where);
6938 : 1 : mpz_clear (index);
6939 : 4 : return &gfc_bad_expr;
6940 : : }
6941 : :
6942 : 21 : gfc_array_size (shape_exp, &size);
6943 : 21 : shape_size = mpz_get_ui (size);
6944 : 21 : mpz_clear (size);
6945 : 21 : gfc_array_size (order_exp, &size);
6946 : 21 : order_size = mpz_get_ui (size);
6947 : 21 : mpz_clear (size);
6948 : 21 : if (order_size != shape_size)
6949 : : {
6950 : 1 : gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
6951 : : &order_exp->where, &shape_exp->where);
6952 : 1 : mpz_clear (index);
6953 : 1 : return &gfc_bad_expr;
6954 : : }
6955 : :
6956 : 58 : for (i = 0; i < rank; i++)
6957 : : {
6958 : 40 : e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
6959 : 40 : gcc_assert (e);
6960 : :
6961 : 40 : gfc_extract_int (e, &order[i]);
6962 : :
6963 : 40 : if (order[i] < 1 || order[i] > rank)
6964 : : {
6965 : 1 : gfc_error ("Element with a value of %d in ORDER at %L must be "
6966 : : "in the range [1, ..., %d] for the RESHAPE intrinsic "
6967 : : "near %L", order[i], &order_exp->where, rank,
6968 : : &shape_exp->where);
6969 : 1 : mpz_clear (index);
6970 : 1 : return &gfc_bad_expr;
6971 : : }
6972 : :
6973 : 39 : order[i]--;
6974 : 39 : if (x[order[i]] != 0)
6975 : : {
6976 : 1 : gfc_error ("ORDER at %L is not a permutation of the size of "
6977 : : "SHAPE at %L", &order_exp->where, &shape_exp->where);
6978 : 1 : mpz_clear (index);
6979 : 1 : return &gfc_bad_expr;
6980 : : }
6981 : 38 : x[order[i]] = 1;
6982 : : }
6983 : : }
6984 : :
6985 : : /* Count the elements in the source and padding arrays. */
6986 : :
6987 : 3611 : npad = 0;
6988 : 3611 : if (pad != NULL)
6989 : : {
6990 : 56 : gfc_array_size (pad, &size);
6991 : 56 : npad = mpz_get_ui (size);
6992 : 56 : mpz_clear (size);
6993 : : }
6994 : :
6995 : 3611 : gfc_array_size (source, &size);
6996 : 3611 : nsource = mpz_get_ui (size);
6997 : 3611 : mpz_clear (size);
6998 : :
6999 : : /* If it weren't for that pesky permutation we could just loop
7000 : : through the source and round out any shortage with pad elements.
7001 : : But no, someone just had to have the compiler do something the
7002 : : user should be doing. */
7003 : :
7004 : 14634 : for (i = 0; i < rank; i++)
7005 : 7412 : x[i] = 0;
7006 : :
7007 : 3611 : result = gfc_get_array_expr (source->ts.type, source->ts.kind,
7008 : : &source->where);
7009 : 3611 : if (source->ts.type == BT_DERIVED)
7010 : 74 : result->ts.u.derived = source->ts.u.derived;
7011 : 3611 : if (source->ts.type == BT_CHARACTER && result->ts.u.cl == NULL)
7012 : 116 : result->ts = source->ts;
7013 : 3611 : result->rank = rank;
7014 : 3611 : result->shape = gfc_get_shape (rank);
7015 : 11023 : for (i = 0; i < rank; i++)
7016 : : {
7017 : 7412 : mpz_init_set_ui (result->shape[i], shape[i]);
7018 : 7412 : if (shape[i] == 0)
7019 : 63 : zerosize = true;
7020 : : }
7021 : :
7022 : 3611 : if (zerosize)
7023 : 51 : goto sizezero;
7024 : :
7025 : 49536 : while (nsource > 0 || npad > 0)
7026 : : {
7027 : : /* Figure out which element to extract. */
7028 : 49536 : mpz_set_ui (index, 0);
7029 : :
7030 : 160266 : for (i = rank - 1; i >= 0; i--)
7031 : : {
7032 : 110730 : mpz_add_ui (index, index, x[order[i]]);
7033 : 110730 : if (i != 0)
7034 : 61194 : mpz_mul_ui (index, index, shape[order[i - 1]]);
7035 : : }
7036 : :
7037 : 49536 : if (mpz_cmp_ui (index, INT_MAX) > 0)
7038 : 0 : gfc_internal_error ("Reshaped array too large at %C");
7039 : :
7040 : 49536 : j = mpz_get_ui (index);
7041 : :
7042 : 49536 : if (j < nsource)
7043 : 49348 : e = gfc_constructor_lookup_expr (source->value.constructor, j);
7044 : : else
7045 : : {
7046 : 188 : if (npad <= 0)
7047 : : {
7048 : 16 : mpz_clear (index);
7049 : 16 : if (pad == NULL)
7050 : 16 : gfc_error ("Without padding, there are not enough elements "
7051 : : "in the intrinsic RESHAPE source at %L to match "
7052 : : "the shape", &source->where);
7053 : 16 : gfc_free_expr (result);
7054 : 16 : return NULL;
7055 : : }
7056 : 172 : j = j - nsource;
7057 : 172 : j = j % npad;
7058 : 172 : e = gfc_constructor_lookup_expr (pad->value.constructor, j);
7059 : : }
7060 : 49520 : gcc_assert (e);
7061 : :
7062 : 49520 : gfc_constructor_append_expr (&result->value.constructor,
7063 : : gfc_copy_expr (e), &e->where);
7064 : :
7065 : : /* Calculate the next element. */
7066 : 49520 : i = 0;
7067 : :
7068 : 63108 : inc:
7069 : 63108 : if (++x[i] < shape[i])
7070 : 45976 : continue;
7071 : 17132 : x[i++] = 0;
7072 : 17132 : if (i < rank)
7073 : 13588 : goto inc;
7074 : :
7075 : : break;
7076 : : }
7077 : :
7078 : 0 : sizezero:
7079 : :
7080 : 3595 : mpz_clear (index);
7081 : :
7082 : 3595 : return result;
7083 : : }
7084 : :
7085 : :
7086 : : gfc_expr *
7087 : 192 : gfc_simplify_rrspacing (gfc_expr *x)
7088 : : {
7089 : 192 : gfc_expr *result;
7090 : 192 : int i;
7091 : 192 : long int e, p;
7092 : :
7093 : 192 : if (x->expr_type != EXPR_CONSTANT)
7094 : : return NULL;
7095 : :
7096 : 60 : i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
7097 : :
7098 : 60 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7099 : :
7100 : : /* RRSPACING(+/- 0.0) = 0.0 */
7101 : 60 : if (mpfr_zero_p (x->value.real))
7102 : : {
7103 : 12 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
7104 : 12 : return result;
7105 : : }
7106 : :
7107 : : /* RRSPACING(inf) = NaN */
7108 : 48 : if (mpfr_inf_p (x->value.real))
7109 : : {
7110 : 12 : mpfr_set_nan (result->value.real);
7111 : 12 : return result;
7112 : : }
7113 : :
7114 : : /* RRSPACING(NaN) = same NaN */
7115 : 36 : if (mpfr_nan_p (x->value.real))
7116 : : {
7117 : 6 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7118 : 6 : return result;
7119 : : }
7120 : :
7121 : : /* | x * 2**(-e) | * 2**p. */
7122 : 30 : mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
7123 : 30 : e = - (long int) mpfr_get_exp (x->value.real);
7124 : 30 : mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
7125 : :
7126 : 30 : p = (long int) gfc_real_kinds[i].digits;
7127 : 30 : mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
7128 : :
7129 : 30 : return range_check (result, "RRSPACING");
7130 : : }
7131 : :
7132 : :
7133 : : gfc_expr *
7134 : 168 : gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
7135 : : {
7136 : 168 : int k, neg_flag, power, exp_range;
7137 : 168 : mpfr_t scale, radix;
7138 : 168 : gfc_expr *result;
7139 : :
7140 : 168 : if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
7141 : : return NULL;
7142 : :
7143 : 12 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7144 : :
7145 : 12 : if (mpfr_zero_p (x->value.real))
7146 : : {
7147 : 0 : mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
7148 : 0 : return result;
7149 : : }
7150 : :
7151 : 12 : k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
7152 : :
7153 : 12 : exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
7154 : :
7155 : : /* This check filters out values of i that would overflow an int. */
7156 : 12 : if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
7157 : 12 : || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
7158 : : {
7159 : 0 : gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
7160 : 0 : gfc_free_expr (result);
7161 : 0 : return &gfc_bad_expr;
7162 : : }
7163 : :
7164 : : /* Compute scale = radix ** power. */
7165 : 12 : power = mpz_get_si (i->value.integer);
7166 : :
7167 : 12 : if (power >= 0)
7168 : : neg_flag = 0;
7169 : : else
7170 : : {
7171 : 0 : neg_flag = 1;
7172 : 0 : power = -power;
7173 : : }
7174 : :
7175 : 12 : gfc_set_model_kind (x->ts.kind);
7176 : 12 : mpfr_init (scale);
7177 : 12 : mpfr_init (radix);
7178 : 12 : mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
7179 : 12 : mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
7180 : :
7181 : 12 : if (neg_flag)
7182 : 0 : mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
7183 : : else
7184 : 12 : mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
7185 : :
7186 : 12 : mpfr_clears (scale, radix, NULL);
7187 : :
7188 : 12 : return range_check (result, "SCALE");
7189 : : }
7190 : :
7191 : :
7192 : : /* Variants of strspn and strcspn that operate on wide characters. */
7193 : :
7194 : : static size_t
7195 : 60 : wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
7196 : : {
7197 : 60 : size_t i = 0;
7198 : 60 : const gfc_char_t *c;
7199 : :
7200 : 144 : while (s1[i])
7201 : : {
7202 : 354 : for (c = s2; *c; c++)
7203 : : {
7204 : 294 : if (s1[i] == *c)
7205 : : break;
7206 : : }
7207 : 144 : if (*c == '\0')
7208 : : break;
7209 : 84 : i++;
7210 : : }
7211 : :
7212 : 60 : return i;
7213 : : }
7214 : :
7215 : : static size_t
7216 : 60 : wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
7217 : : {
7218 : 60 : size_t i = 0;
7219 : 60 : const gfc_char_t *c;
7220 : :
7221 : 396 : while (s1[i])
7222 : : {
7223 : 1392 : for (c = s2; *c; c++)
7224 : : {
7225 : 1056 : if (s1[i] == *c)
7226 : : break;
7227 : : }
7228 : 384 : if (*c)
7229 : : break;
7230 : 336 : i++;
7231 : : }
7232 : :
7233 : 60 : return i;
7234 : : }
7235 : :
7236 : :
7237 : : gfc_expr *
7238 : 958 : gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
7239 : : {
7240 : 958 : gfc_expr *result;
7241 : 958 : int back;
7242 : 958 : size_t i;
7243 : 958 : size_t indx, len, lenc;
7244 : 958 : int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
7245 : :
7246 : 958 : if (k == -1)
7247 : : return &gfc_bad_expr;
7248 : :
7249 : 958 : if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
7250 : 182 : || ( b != NULL && b->expr_type != EXPR_CONSTANT))
7251 : : return NULL;
7252 : :
7253 : 144 : if (b != NULL && b->value.logical != 0)
7254 : : back = 1;
7255 : : else
7256 : 72 : back = 0;
7257 : :
7258 : 144 : len = e->value.character.length;
7259 : 144 : lenc = c->value.character.length;
7260 : :
7261 : 144 : if (len == 0 || lenc == 0)
7262 : : {
7263 : : indx = 0;
7264 : : }
7265 : : else
7266 : : {
7267 : 120 : if (back == 0)
7268 : : {
7269 : 60 : indx = wide_strcspn (e->value.character.string,
7270 : 60 : c->value.character.string) + 1;
7271 : 60 : if (indx > len)
7272 : 48 : indx = 0;
7273 : : }
7274 : : else
7275 : 408 : for (indx = len; indx > 0; indx--)
7276 : : {
7277 : 1488 : for (i = 0; i < lenc; i++)
7278 : : {
7279 : 1140 : if (c->value.character.string[i]
7280 : 1140 : == e->value.character.string[indx - 1])
7281 : : break;
7282 : : }
7283 : 396 : if (i < lenc)
7284 : : break;
7285 : : }
7286 : : }
7287 : :
7288 : 144 : result = gfc_get_int_expr (k, &e->where, indx);
7289 : 144 : return range_check (result, "SCAN");
7290 : : }
7291 : :
7292 : :
7293 : : gfc_expr *
7294 : 245 : gfc_simplify_selected_char_kind (gfc_expr *e)
7295 : : {
7296 : 245 : int kind;
7297 : :
7298 : 245 : if (e->expr_type != EXPR_CONSTANT)
7299 : : return NULL;
7300 : :
7301 : 160 : if (gfc_compare_with_Cstring (e, "ascii", false) == 0
7302 : 160 : || gfc_compare_with_Cstring (e, "default", false) == 0)
7303 : : kind = 1;
7304 : 76 : else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
7305 : : kind = 4;
7306 : : else
7307 : 39 : kind = -1;
7308 : :
7309 : 160 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
7310 : : }
7311 : :
7312 : :
7313 : : gfc_expr *
7314 : 250 : gfc_simplify_selected_int_kind (gfc_expr *e)
7315 : : {
7316 : 250 : int i, kind, range;
7317 : :
7318 : 250 : if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
7319 : 49 : return NULL;
7320 : :
7321 : : kind = INT_MAX;
7322 : :
7323 : 1206 : for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
7324 : 1005 : if (gfc_integer_kinds[i].range >= range
7325 : 524 : && gfc_integer_kinds[i].kind < kind)
7326 : 1005 : kind = gfc_integer_kinds[i].kind;
7327 : :
7328 : 201 : if (kind == INT_MAX)
7329 : 0 : kind = -1;
7330 : :
7331 : 201 : return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
7332 : : }
7333 : :
7334 : :
7335 : : gfc_expr *
7336 : 992 : gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
7337 : : {
7338 : 992 : int range, precision, radix, i, kind, found_precision, found_range,
7339 : : found_radix;
7340 : 992 : locus *loc = &gfc_current_locus;
7341 : :
7342 : 992 : if (p == NULL)
7343 : 60 : precision = 0;
7344 : : else
7345 : : {
7346 : 932 : if (p->expr_type != EXPR_CONSTANT
7347 : 932 : || gfc_extract_int (p, &precision))
7348 : 46 : return NULL;
7349 : 886 : loc = &p->where;
7350 : : }
7351 : :
7352 : 946 : if (q == NULL)
7353 : 682 : range = 0;
7354 : : else
7355 : : {
7356 : 264 : if (q->expr_type != EXPR_CONSTANT
7357 : 264 : || gfc_extract_int (q, &range))
7358 : 54 : return NULL;
7359 : :
7360 : : if (!loc)
7361 : : loc = &q->where;
7362 : : }
7363 : :
7364 : 892 : if (rdx == NULL)
7365 : 832 : radix = 0;
7366 : : else
7367 : : {
7368 : 60 : if (rdx->expr_type != EXPR_CONSTANT
7369 : 60 : || gfc_extract_int (rdx, &radix))
7370 : 24 : return NULL;
7371 : :
7372 : : if (!loc)
7373 : : loc = &rdx->where;
7374 : : }
7375 : :
7376 : 868 : kind = INT_MAX;
7377 : 868 : found_precision = 0;
7378 : 868 : found_range = 0;
7379 : 868 : found_radix = 0;
7380 : :
7381 : 4340 : for (i = 0; gfc_real_kinds[i].kind != 0; i++)
7382 : : {
7383 : 3472 : if (gfc_real_kinds[i].precision >= precision)
7384 : 2351 : found_precision = 1;
7385 : :
7386 : 3472 : if (gfc_real_kinds[i].range >= range)
7387 : 3351 : found_range = 1;
7388 : :
7389 : 3472 : if (radix == 0 || gfc_real_kinds[i].radix == radix)
7390 : 3448 : found_radix = 1;
7391 : :
7392 : 3472 : if (gfc_real_kinds[i].precision >= precision
7393 : 2351 : && gfc_real_kinds[i].range >= range
7394 : 2351 : && (radix == 0 || gfc_real_kinds[i].radix == radix)
7395 : 2327 : && gfc_real_kinds[i].kind < kind)
7396 : 3472 : kind = gfc_real_kinds[i].kind;
7397 : : }
7398 : :
7399 : 868 : if (kind == INT_MAX)
7400 : : {
7401 : 12 : if (found_radix && found_range && !found_precision)
7402 : : kind = -1;
7403 : 6 : else if (found_radix && found_precision && !found_range)
7404 : : kind = -2;
7405 : 6 : else if (found_radix && !found_precision && !found_range)
7406 : : kind = -3;
7407 : 6 : else if (found_radix)
7408 : : kind = -4;
7409 : : else
7410 : 6 : kind = -5;
7411 : : }
7412 : :
7413 : 868 : return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
7414 : : }
7415 : :
7416 : :
7417 : : gfc_expr *
7418 : 770 : gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
7419 : : {
7420 : 770 : gfc_expr *result;
7421 : 770 : mpfr_t exp, absv, log2, pow2, frac;
7422 : 770 : long exp2;
7423 : :
7424 : 770 : if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
7425 : : return NULL;
7426 : :
7427 : 150 : result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7428 : :
7429 : : /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7430 : : SET_EXPONENT (NaN) = same NaN */
7431 : 150 : if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real))
7432 : : {
7433 : 18 : mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7434 : 18 : return result;
7435 : : }
7436 : :
7437 : : /* SET_EXPONENT (inf) = NaN */
7438 : 132 : if (mpfr_inf_p (x->value.real))
7439 : : {
7440 : 12 : mpfr_set_nan (result->value.real);
7441 : 12 : return result;
7442 : : }
7443 : :
7444 : 120 : gfc_set_model_kind (x->ts.kind);
7445 : 120 : mpfr_init (absv);
7446 : 120 : mpfr_init (log2);
7447 : 120 : mpfr_init (exp);
7448 : 120 : mpfr_init (pow2);
7449 : 120 : mpfr_init (frac);
7450 : :
7451 : 120 : mpfr_abs (absv, x->value.real, GFC_RND_MODE);
7452 : 120 : mpfr_log2 (log2, absv, GFC_RND_MODE);
7453 : :
7454 : 120 : mpfr_floor (log2, log2);
7455 : 120 : mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
7456 : :
7457 : : /* Old exponent value, and fraction. */
7458 : 120 : mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
7459 : :
7460 : 120 : mpfr_div (frac, x->value.real, pow2, GFC_RND_MODE);
7461 : :
7462 : : /* New exponent. */
7463 : 120 : exp2 = mpz_get_si (i->value.integer);
7464 : 120 : mpfr_mul_2si (result->value.real, frac, exp2, GFC_RND_MODE);
7465 : :
7466 : 120 : mpfr_clears (absv, log2, exp, pow2, frac, NULL);
7467 : :
7468 : 120 : return range_check (result, "SET_EXPONENT");
7469 : : }
7470 : :
7471 : :
7472 : : gfc_expr *
7473 : 3286 : gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
7474 : : {
7475 : 3286 : mpz_t shape[GFC_MAX_DIMENSIONS];
7476 : 3286 : gfc_expr *result, *e, *f;
7477 : 3286 : gfc_array_ref *ar;
7478 : 3286 : int n;
7479 : 3286 : bool t;
7480 : 3286 : int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
7481 : :
7482 : 3286 : if (source->rank == -1)
7483 : : return NULL;
7484 : :
7485 : 2434 : result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
7486 : 2434 : result->shape = gfc_get_shape (1);
7487 : 2434 : mpz_init (result->shape[0]);
7488 : :
7489 : 2434 : if (source->rank == 0)
7490 : : return result;
7491 : :
7492 : 2383 : if (source->expr_type == EXPR_VARIABLE)
7493 : : {
7494 : 2357 : ar = gfc_find_array_ref (source);
7495 : 2357 : t = gfc_array_ref_shape (ar, shape);
7496 : : }
7497 : 26 : else if (source->shape)
7498 : : {
7499 : 37 : t = true;
7500 : 37 : for (n = 0; n < source->rank; n++)
7501 : : {
7502 : 24 : mpz_init (shape[n]);
7503 : 24 : mpz_set (shape[n], source->shape[n]);
7504 : : }
7505 : : }
7506 : : else
7507 : : t = false;
7508 : :
7509 : 4203 : for (n = 0; n < source->rank; n++)
7510 : : {
7511 : 3298 : e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
7512 : :
7513 : 3298 : if (t)
7514 : 1806 : mpz_set (e->value.integer, shape[n]);
7515 : : else
7516 : : {
7517 : 1492 : mpz_set_ui (e->value.integer, n + 1);
7518 : :
7519 : 1492 : f = simplify_size (source, e, k);
7520 : 1492 : gfc_free_expr (e);
7521 : 1492 : if (f == NULL)
7522 : : {
7523 : 1477 : gfc_free_expr (result);
7524 : 1477 : return NULL;
7525 : : }
7526 : : else
7527 : : e = f;
7528 : : }
7529 : :
7530 : 1821 : if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
7531 : : {
7532 : 1 : gfc_free_expr (result);
7533 : 1 : if (t)
7534 : 1 : gfc_clear_shape (shape, source->rank);
7535 : 1 : return &gfc_bad_expr;
7536 : : }
7537 : :
7538 : 1820 : gfc_constructor_append_expr (&result->value.constructor, e, NULL);
7539 : : }
7540 : :
7541 : 905 : if (t)
7542 : 905 : gfc_clear_shape (shape, source->rank);
7543 : :
7544 : 905 : mpz_set_si (result->shape[0], source->rank);
7545 : :
7546 : 905 : return result;
7547 : : }
7548 : :
7549 : :
7550 : : static gfc_expr *
7551 : 30541 : simplify_size (gfc_expr *array, gfc_expr *dim, int k)
7552 : : {
7553 : 30541 : mpz_t size;
7554 : 30541 : gfc_expr *return_value;
7555 : 30541 : int d;
7556 : 30541 : gfc_ref *ref;
7557 : :
7558 : : /* For unary operations, the size of the result is given by the size
7559 : : of the operand. For binary ones, it's the size of the first operand
7560 : : unless it is scalar, then it is the size of the second. */
7561 : 30541 : if (array->expr_type == EXPR_OP && !array->value.op.uop)
7562 : : {
7563 : 44 : gfc_expr* replacement;
7564 : 44 : gfc_expr* simplified;
7565 : :
7566 : 44 : switch (array->value.op.op)
7567 : : {
7568 : : /* Unary operations. */
7569 : 7 : case INTRINSIC_NOT:
7570 : 7 : case INTRINSIC_UPLUS:
7571 : 7 : case INTRINSIC_UMINUS:
7572 : 7 : case INTRINSIC_PARENTHESES:
7573 : 7 : replacement = array->value.op.op1;
7574 : 7 : break;
7575 : :
7576 : : /* Binary operations. If any one of the operands is scalar, take
7577 : : the other one's size. If both of them are arrays, it does not
7578 : : matter -- try to find one with known shape, if possible. */
7579 : 37 : default:
7580 : 37 : if (array->value.op.op1->rank == 0)
7581 : 25 : replacement = array->value.op.op2;
7582 : 12 : else if (array->value.op.op2->rank == 0)
7583 : : replacement = array->value.op.op1;
7584 : : else
7585 : : {
7586 : 0 : simplified = simplify_size (array->value.op.op1, dim, k);
7587 : 0 : if (simplified)
7588 : : return simplified;
7589 : :
7590 : 0 : replacement = array->value.op.op2;
7591 : : }
7592 : : break;
7593 : : }
7594 : :
7595 : : /* Try to reduce it directly if possible. */
7596 : 44 : simplified = simplify_size (replacement, dim, k);
7597 : :
7598 : : /* Otherwise, we build a new SIZE call. This is hopefully at least
7599 : : simpler than the original one. */
7600 : 44 : if (!simplified)
7601 : : {
7602 : 20 : gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
7603 : 20 : simplified = gfc_build_intrinsic_call (gfc_current_ns,
7604 : : GFC_ISYM_SIZE, "size",
7605 : : array->where, 3,
7606 : : gfc_copy_expr (replacement),
7607 : : gfc_copy_expr (dim),
7608 : : kind);
7609 : : }
7610 : 44 : return simplified;
7611 : : }
7612 : :
7613 : 61648 : for (ref = array->ref; ref; ref = ref->next)
7614 : 28673 : if (ref->type == REF_ARRAY && ref->u.ar.as
7615 : 59828 : && !gfc_resolve_array_spec (ref->u.ar.as, 0))
7616 : : return NULL;
7617 : :
7618 : 30493 : if (dim == NULL)
7619 : : {
7620 : 13492 : if (!gfc_array_size (array, &size))
7621 : : return NULL;
7622 : : }
7623 : : else
7624 : : {
7625 : 17001 : if (dim->expr_type != EXPR_CONSTANT)
7626 : : return NULL;
7627 : :
7628 : 16703 : if (array->rank == -1)
7629 : : return NULL;
7630 : :
7631 : 16061 : d = mpz_get_si (dim->value.integer) - 1;
7632 : 16061 : if (d < 0 || d > array->rank - 1)
7633 : : {
7634 : 6 : gfc_error ("DIM argument (%d) to intrinsic SIZE at %L out of range "
7635 : : "(1:%d)", d+1, &array->where, array->rank);
7636 : 6 : return &gfc_bad_expr;
7637 : : }
7638 : :
7639 : 16055 : if (!gfc_array_dimen_size (array, d, &size))
7640 : : return NULL;
7641 : : }
7642 : :
7643 : 4793 : return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
7644 : 4793 : mpz_set (return_value->value.integer, size);
7645 : 4793 : mpz_clear (size);
7646 : :
7647 : 4793 : return return_value;
7648 : : }
7649 : :
7650 : :
7651 : : gfc_expr *
7652 : 28223 : gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
7653 : : {
7654 : 28223 : gfc_expr *result;
7655 : 28223 : int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
7656 : :
7657 : 28223 : if (k == -1)
7658 : : return &gfc_bad_expr;
7659 : :
7660 : 28223 : result = simplify_size (array, dim, k);
7661 : 28223 : if (result == NULL || result == &gfc_bad_expr)
7662 : : return result;
7663 : :
7664 : 4391 : return range_check (result, "SIZE");
7665 : : }
7666 : :
7667 : :
7668 : : /* SIZEOF and C_SIZEOF return the size in bytes of an array element
7669 : : multiplied by the array size. */
7670 : :
7671 : : gfc_expr *
7672 : 3237 : gfc_simplify_sizeof (gfc_expr *x)
7673 : : {
7674 : 3237 : gfc_expr *result = NULL;
7675 : 3237 : mpz_t array_size;
7676 : 3237 : size_t res_size;
7677 : :
7678 : 3237 : if (x->ts.type == BT_CLASS || x->ts.deferred)
7679 : : return NULL;
7680 : :
7681 : 2187 : if (x->ts.type == BT_CHARACTER
7682 : 248 : && (!x->ts.u.cl || !x->ts.u.cl->length
7683 : 74 : || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
7684 : : return NULL;
7685 : :
7686 : 1326 : if (x->rank && x->expr_type != EXPR_ARRAY
7687 : 3309 : && !gfc_array_size (x, &array_size))
7688 : : return NULL;
7689 : :
7690 : 827 : result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
7691 : : &x->where);
7692 : 827 : gfc_target_expr_size (x, &res_size);
7693 : 827 : mpz_set_si (result->value.integer, res_size);
7694 : :
7695 : 827 : return result;
7696 : : }
7697 : :
7698 : :
7699 : : /* STORAGE_SIZE returns the size in bits of a single array element. */
7700 : :
7701 : : gfc_expr *
7702 : 1170 : gfc_simplify_storage_size (gfc_expr *x,
7703 : : gfc_expr *kind)
7704 : : {
7705 : 1170 : gfc_expr *result = NULL;
7706 : 1170 : int k;
7707 : 1170 : size_t siz;
7708 : :
7709 : 1170 : if (x->ts.type == BT_CLASS || x->ts.deferred)
7710 : : return NULL;
7711 : :
7712 : 737 : if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
7713 : 297 : && (!x->ts.u.cl || !x->ts.u.cl->length
7714 : 96 : || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
7715 : : return NULL;
7716 : :
7717 : 536 : k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
7718 : 536 : if (k == -1)
7719 : : return &gfc_bad_expr;
7720 : :
7721 : 536 : result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
7722 : :
7723 : 536 : gfc_element_size (x, &siz);
7724 : 536 : mpz_set_si (result->value.integer, siz);
7725 : 536 : mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
7726 : :
7727 : 536 : return range_check (result, "STORAGE_SIZE");
7728 : : }
7729 : :
7730 : :
7731 : : gfc_expr *
7732 : 1420 : gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
7733 : : {
7734 : 1420 : gfc_expr *result;
7735 : :
7736 : 1420 : if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
7737 : : return NULL;
7738 : :
7739 : 95 : result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7740 : :
7741 : 95 : switch (x->ts.type)
7742 : : {
7743 : 22 : case BT_INTEGER:
7744 : 22 : mpz_abs (result->value.integer, x->value.integer);
7745 : 22 : if (mpz_sgn (y->value.integer) < 0)
7746 : 0 : mpz_neg (result->value.integer, result->value.integer);
7747 : : break;
7748 : :
7749 : 73 : case BT_REAL:
7750 : 73 : if (flag_sign_zero)
7751 : 61 : mpfr_copysign (result->value.real, x->value.real, y->value.real,
7752 : : GFC_RND_MODE);
7753 : : else
7754 : 24 : mpfr_setsign (result->value.real, x->value.real,
7755 : : mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
7756 : : break;
7757 : :
7758 : 0 : default:
7759 : 0 : gfc_internal_error ("Bad type in gfc_simplify_sign");
7760 : : }
7761 : :
7762 : : return result;
7763 : : }
7764 : :
7765 : |
