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