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