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