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