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