?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
20180-12-08 Steven G. Kargl <kargl@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / simplify.c
blobcdf748e4990d9c3a0d79bd67f77e0183ae83cd38
1 /* Simplify intrinsic functions at compile-time.
2 Copyright (C) 2000-2018 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 count[0]++;
640 base += sstride[0];
641 dest += dstride[0];
642
643 n = 0;
644 while (!done && count[n] == extent[n])
645 {
646 count[n] = 0;
647 base -= sstride[n] * extent[n];
648 dest -= dstride[n] * extent[n];
649
650 n++;
651 if (n < result->rank)
652 {
653 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
654 times, we'd warn for the last iteration, because the
655 array index will have already been incremented to the
656 array sizes, and we can't tell that this must make
657 the test against result->rank false, because ranks
658 must not exceed GFC_MAX_DIMENSIONS. */
659 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
660 count[n]++;
661 base += sstride[n];
662 dest += dstride[n];
663 GCC_DIAGNOSTIC_POP
664 }
665 else
666 done = true;
667 }
668 }
669
670 /* Place updated expression in result constructor. */
671 result_ctor = gfc_constructor_first (result->value.constructor);
672 for (i = 0; i < resultsize; ++i)
673 {
674 if (post_op)
675 result_ctor->expr = post_op (result_ctor->expr, resultvec[i]);
676 else
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);
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
4967 last = NULL;
4968 extremum = NULL;
4969
4970 arg = expr->value.function.actual;
4971
4972 for (; arg; last = arg, arg = arg->next)
4973 {
4974 if (arg->expr->expr_type != EXPR_CONSTANT)
4975 continue;
4976
4977 if (extremum == NULL)
4978 {
4979 extremum = arg;
4980 continue;
4981 }
4982
4983 min_max_choose (arg->expr, extremum->expr, sign);
4984
4985 /* Delete the extra constant argument. */
4986 last->next = arg->next;
4987
4988 arg->next = NULL;
4989 gfc_free_actual_arglist (arg);
4990 arg = last;
4991 }
4992
4993 /* If there is one value left, replace the function call with the
4994 expression. */
4995 if (expr->value.function.actual->next != NULL)
4996 return NULL;
4997
4998 return gfc_copy_expr (expr->value.function.actual->expr);
4999 }
5000
5001
5002 gfc_expr *
5003 gfc_simplify_min (gfc_expr *e)
5004 {
5005 return simplify_min_max (e, -1);
5006 }
5007
5008
5009 gfc_expr *
5010 gfc_simplify_max (gfc_expr *e)
5011 {
5012 return simplify_min_max (e, 1);
5013 }
5014
5015 /* Helper function for gfc_simplify_minval. */
5016
5017 static gfc_expr *
5018 gfc_min (gfc_expr *op1, gfc_expr *op2)
5019 {
5020 min_max_choose (op1, op2, -1);
5021 gfc_free_expr (op1);
5022 return op2;
5023 }
5024
5025 /* Simplify minval for constant arrays. */
5026
5027 gfc_expr *
5028 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5029 {
5030 return simplify_transformation (array, dim, mask, INT_MAX, gfc_min);
5031 }
5032
5033 /* Helper function for gfc_simplify_maxval. */
5034
5035 static gfc_expr *
5036 gfc_max (gfc_expr *op1, gfc_expr *op2)
5037 {
5038 min_max_choose (op1, op2, 1);
5039 gfc_free_expr (op1);
5040 return op2;
5041 }
5042
5043
5044 /* Simplify maxval for constant arrays. */
5045
5046 gfc_expr *
5047 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5048 {
5049 return simplify_transformation (array, dim, mask, INT_MIN, gfc_max);
5050 }
5051
5052
5053 /* Transform minloc or maxloc of an array, according to MASK,
5054 to the scalar result. This code is mostly identical to
5055 simplify_transformation_to_scalar. */
5056
5057 static gfc_expr *
5058 simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
5059 gfc_expr *extremum, int sign, bool back_val)
5060 {
5061 gfc_expr *a, *m;
5062 gfc_constructor *array_ctor, *mask_ctor;
5063 mpz_t count;
5064
5065 mpz_set_si (result->value.integer, 0);
5066
5067
5068 /* Shortcut for constant .FALSE. MASK. */
5069 if (mask
5070 && mask->expr_type == EXPR_CONSTANT
5071 && !mask->value.logical)
5072 return result;
5073
5074 array_ctor = gfc_constructor_first (array->value.constructor);
5075 if (mask && mask->expr_type == EXPR_ARRAY)
5076 mask_ctor = gfc_constructor_first (mask->value.constructor);
5077 else
5078 mask_ctor = NULL;
5079
5080 mpz_init_set_si (count, 0);
5081 while (array_ctor)
5082 {
5083 mpz_add_ui (count, count, 1);
5084 a = array_ctor->expr;
5085 array_ctor = gfc_constructor_next (array_ctor);
5086 /* A constant MASK equals .TRUE. here and can be ignored. */
5087 if (mask_ctor)
5088 {
5089 m = mask_ctor->expr;
5090 mask_ctor = gfc_constructor_next (mask_ctor);
5091 if (!m->value.logical)
5092 continue;
5093 }
5094 if (min_max_choose (a, extremum, sign, back_val) > 0)
5095 mpz_set (result->value.integer, count);
5096 }
5097 mpz_clear (count);
5098 gfc_free_expr (extremum);
5099 return result;
5100 }
5101
5102 /* Simplify minloc / maxloc in the absence of a dim argument. */
5103
5104 static gfc_expr *
5105 simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
5106 gfc_expr *array, gfc_expr *mask, int sign,
5107 bool back_val)
5108 {
5109 ssize_t res[GFC_MAX_DIMENSIONS];
5110 int i, n;
5111 gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5112 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5113 sstride[GFC_MAX_DIMENSIONS];
5114 gfc_expr *a, *m;
5115 bool continue_loop;
5116 bool ma;
5117
5118 for (i = 0; i<array->rank; i++)
5119 res[i] = -1;
5120
5121 /* Shortcut for constant .FALSE. MASK. */
5122 if (mask
5123 && mask->expr_type == EXPR_CONSTANT
5124 && !mask->value.logical)
5125 goto finish;
5126
5127 for (i = 0; i < array->rank; i++)
5128 {
5129 count[i] = 0;
5130 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5131 extent[i] = mpz_get_si (array->shape[i]);
5132 if (extent[i] <= 0)
5133 goto finish;
5134 }
5135
5136 continue_loop = true;
5137 array_ctor = gfc_constructor_first (array->value.constructor);
5138 if (mask && mask->rank > 0)
5139 mask_ctor = gfc_constructor_first (mask->value.constructor);
5140 else
5141 mask_ctor = NULL;
5142
5143 /* Loop over the array elements (and mask), keeping track of
5144 the indices to return. */
5145 while (continue_loop)
5146 {
5147 do
5148 {
5149 a = array_ctor->expr;
5150 if (mask_ctor)
5151 {
5152 m = mask_ctor->expr;
5153 ma = m->value.logical;
5154 mask_ctor = gfc_constructor_next (mask_ctor);
5155 }
5156 else
5157 ma = true;
5158
5159 if (ma && min_max_choose (a, extremum, sign, back_val) > 0)
5160 {
5161 for (i = 0; i<array->rank; i++)
5162 res[i] = count[i];
5163 }
5164 array_ctor = gfc_constructor_next (array_ctor);
5165 count[0] ++;
5166 } while (count[0] != extent[0]);
5167 n = 0;
5168 do
5169 {
5170 /* When we get to the end of a dimension, reset it and increment
5171 the next dimension. */
5172 count[n] = 0;
5173 n++;
5174 if (n >= array->rank)
5175 {
5176 continue_loop = false;
5177 break;
5178 }
5179 else
5180 count[n] ++;
5181 } while (count[n] == extent[n]);
5182 }
5183
5184 finish:
5185 gfc_free_expr (extremum);
5186 result_ctor = gfc_constructor_first (result->value.constructor);
5187 for (i = 0; i<array->rank; i++)
5188 {
5189 gfc_expr *r_expr;
5190 r_expr = result_ctor->expr;
5191 mpz_set_si (r_expr->value.integer, res[i] + 1);
5192 result_ctor = gfc_constructor_next (result_ctor);
5193 }
5194 return result;
5195 }
5196
5197 /* Helper function for gfc_simplify_minmaxloc - build an array
5198 expression with n elements. */
5199
5200 static gfc_expr *
5201 new_array (bt type, int kind, int n, locus *where)
5202 {
5203 gfc_expr *result;
5204 int i;
5205
5206 result = gfc_get_array_expr (type, kind, where);
5207 result->rank = 1;
5208 result->shape = gfc_get_shape(1);
5209 mpz_init_set_si (result->shape[0], n);
5210 for (i = 0; i < n; i++)
5211 {
5212 gfc_constructor_append_expr (&result->value.constructor,
5213 gfc_get_constant_expr (type, kind, where),
5214 NULL);
5215 }
5216
5217 return result;
5218 }
5219
5220 /* Simplify minloc and maxloc. This code is mostly identical to
5221 simplify_transformation_to_array. */
5222
5223 static gfc_expr *
5224 simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
5225 gfc_expr *dim, gfc_expr *mask,
5226 gfc_expr *extremum, int sign, bool back_val)
5227 {
5228 mpz_t size;
5229 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5230 gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5231 gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5232
5233 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5234 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
5235 tmpstride[GFC_MAX_DIMENSIONS];
5236
5237 /* Shortcut for constant .FALSE. MASK. */
5238 if (mask
5239 && mask->expr_type == EXPR_CONSTANT
5240 && !mask->value.logical)
5241 return result;
5242
5243 /* Build an indexed table for array element expressions to minimize
5244 linked-list traversal. Masked elements are set to NULL. */
5245 gfc_array_size (array, &size);
5246 arraysize = mpz_get_ui (size);
5247 mpz_clear (size);
5248
5249 arrayvec = XCNEWVEC (gfc_expr*, arraysize);
5250
5251 array_ctor = gfc_constructor_first (array->value.constructor);
5252 mask_ctor = NULL;
5253 if (mask && mask->expr_type == EXPR_ARRAY)
5254 mask_ctor = gfc_constructor_first (mask->value.constructor);
5255
5256 for (i = 0; i < arraysize; ++i)
5257 {
5258 arrayvec[i] = array_ctor->expr;
5259 array_ctor = gfc_constructor_next (array_ctor);
5260
5261 if (mask_ctor)
5262 {
5263 if (!mask_ctor->expr->value.logical)
5264 arrayvec[i] = NULL;
5265
5266 mask_ctor = gfc_constructor_next (mask_ctor);
5267 }
5268 }
5269
5270 /* Same for the result expression. */
5271 gfc_array_size (result, &size);
5272 resultsize = mpz_get_ui (size);
5273 mpz_clear (size);
5274
5275 resultvec = XCNEWVEC (gfc_expr*, resultsize);
5276 result_ctor = gfc_constructor_first (result->value.constructor);
5277 for (i = 0; i < resultsize; ++i)
5278 {
5279 resultvec[i] = result_ctor->expr;
5280 result_ctor = gfc_constructor_next (result_ctor);
5281 }
5282
5283 gfc_extract_int (dim, &dim_index);
5284 dim_index -= 1; /* zero-base index */
5285 dim_extent = 0;
5286 dim_stride = 0;
5287
5288 for (i = 0, n = 0; i < array->rank; ++i)
5289 {
5290 count[i] = 0;
5291 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
5292 if (i == dim_index)
5293 {
5294 dim_extent = mpz_get_si (array->shape[i]);
5295 dim_stride = tmpstride[i];
5296 continue;
5297 }
5298
5299 extent[n] = mpz_get_si (array->shape[i]);
5300 sstride[n] = tmpstride[i];
5301 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5302 n += 1;
5303 }
5304
5305 done = resultsize <= 0;
5306 base = arrayvec;
5307 dest = resultvec;
5308 while (!done)
5309 {
5310 gfc_expr *ex;
5311 ex = gfc_copy_expr (extremum);
5312 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5313 {
5314 if (*src && min_max_choose (*src, ex, sign, back_val) > 0)
5315 mpz_set_si ((*dest)->value.integer, n + 1);
5316 }
5317
5318 count[0]++;
5319 base += sstride[0];
5320 dest += dstride[0];
5321 gfc_free_expr (ex);
5322
5323 n = 0;
5324 while (!done && count[n] == extent[n])
5325 {
5326 count[n] = 0;
5327 base -= sstride[n] * extent[n];
5328 dest -= dstride[n] * extent[n];
5329
5330 n++;
5331 if (n < result->rank)
5332 {
5333 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5334 times, we'd warn for the last iteration, because the
5335 array index will have already been incremented to the
5336 array sizes, and we can't tell that this must make
5337 the test against result->rank false, because ranks
5338 must not exceed GFC_MAX_DIMENSIONS. */
5339 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5340 count[n]++;
5341 base += sstride[n];
5342 dest += dstride[n];
5343 GCC_DIAGNOSTIC_POP
5344 }
5345 else
5346 done = true;
5347 }
5348 }
5349
5350 /* Place updated expression in result constructor. */
5351 result_ctor = gfc_constructor_first (result->value.constructor);
5352 for (i = 0; i < resultsize; ++i)
5353 {
5354 result_ctor->expr = resultvec[i];
5355 result_ctor = gfc_constructor_next (result_ctor);
5356 }
5357
5358 free (arrayvec);
5359 free (resultvec);
5360 free (extremum);
5361 return result;
5362 }
5363
5364 /* Simplify minloc and maxloc for constant arrays. */
5365
5366 static gfc_expr *
5367 gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
5368 gfc_expr *kind, gfc_expr *back, int sign)
5369 {
5370 gfc_expr *result;
5371 gfc_expr *extremum;
5372 int ikind;
5373 int init_val;
5374 bool back_val = false;
5375
5376 if (!is_constant_array_expr (array)
5377 || !gfc_is_constant_expr (dim))
5378 return NULL;
5379
5380 if (mask
5381 && !is_constant_array_expr (mask)
5382 && mask->expr_type != EXPR_CONSTANT)
5383 return NULL;
5384
5385 if (kind)
5386 {
5387 if (gfc_extract_int (kind, &ikind, -1))
5388 return NULL;
5389 }
5390 else
5391 ikind = gfc_default_integer_kind;
5392
5393 if (back)
5394 {
5395 if (back->expr_type != EXPR_CONSTANT)
5396 return NULL;
5397
5398 back_val = back->value.logical;
5399 }
5400
5401 if (sign < 0)
5402 init_val = INT_MAX;
5403 else if (sign > 0)
5404 init_val = INT_MIN;
5405 else
5406 gcc_unreachable();
5407
5408 extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
5409 init_result_expr (extremum, init_val, array);
5410
5411 if (dim)
5412 {
5413 result = transformational_result (array, dim, BT_INTEGER,
5414 ikind, &array->where);
5415 init_result_expr (result, 0, array);
5416
5417 if (array->rank == 1)
5418 return simplify_minmaxloc_to_scalar (result, array, mask, extremum,
5419 sign, back_val);
5420 else
5421 return simplify_minmaxloc_to_array (result, array, dim, mask, extremum,
5422 sign, back_val);
5423 }
5424 else
5425 {
5426 result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
5427 return simplify_minmaxloc_nodim (result, extremum, array, mask,
5428 sign, back_val);
5429 }
5430 }
5431
5432 gfc_expr *
5433 gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5434 gfc_expr *back)
5435 {
5436 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1);
5437 }
5438
5439 gfc_expr *
5440 gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
5441 gfc_expr *back)
5442 {
5443 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
5444 }
5445
5446 /* Simplify findloc to scalar. Similar to
5447 simplify_minmaxloc_to_scalar. */
5448
5449 static gfc_expr *
5450 simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5451 gfc_expr *mask, int back_val)
5452 {
5453 gfc_expr *a, *m;
5454 gfc_constructor *array_ctor, *mask_ctor;
5455 mpz_t count;
5456
5457 mpz_set_si (result->value.integer, 0);
5458
5459 /* Shortcut for constant .FALSE. MASK. */
5460 if (mask
5461 && mask->expr_type == EXPR_CONSTANT
5462 && !mask->value.logical)
5463 return result;
5464
5465 array_ctor = gfc_constructor_first (array->value.constructor);
5466 if (mask && mask->expr_type == EXPR_ARRAY)
5467 mask_ctor = gfc_constructor_first (mask->value.constructor);
5468 else
5469 mask_ctor = NULL;
5470
5471 mpz_init_set_si (count, 0);
5472 while (array_ctor)
5473 {
5474 mpz_add_ui (count, count, 1);
5475 a = array_ctor->expr;
5476 array_ctor = gfc_constructor_next (array_ctor);
5477 /* A constant MASK equals .TRUE. here and can be ignored. */
5478 if (mask_ctor)
5479 {
5480 m = mask_ctor->expr;
5481 mask_ctor = gfc_constructor_next (mask_ctor);
5482 if (!m->value.logical)
5483 continue;
5484 }
5485 if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5486 {
5487 /* We have a match. If BACK is true, continue so we find
5488 the last one. */
5489 mpz_set (result->value.integer, count);
5490 if (!back_val)
5491 break;
5492 }
5493 }
5494 mpz_clear (count);
5495 return result;
5496 }
5497
5498 /* Simplify findloc in the absence of a dim argument. Similar to
5499 simplify_minmaxloc_nodim. */
5500
5501 static gfc_expr *
5502 simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
5503 gfc_expr *mask, bool back_val)
5504 {
5505 ssize_t res[GFC_MAX_DIMENSIONS];
5506 int i, n;
5507 gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
5508 ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5509 sstride[GFC_MAX_DIMENSIONS];
5510 gfc_expr *a, *m;
5511 bool continue_loop;
5512 bool ma;
5513
5514 for (i = 0; i<array->rank; i++)
5515 res[i] = -1;
5516
5517 /* Shortcut for constant .FALSE. MASK. */
5518 if (mask
5519 && mask->expr_type == EXPR_CONSTANT
5520 && !mask->value.logical)
5521 goto finish;
5522
5523 for (i = 0; i < array->rank; i++)
5524 {
5525 count[i] = 0;
5526 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
5527 extent[i] = mpz_get_si (array->shape[i]);
5528 if (extent[i] <= 0)
5529 goto finish;
5530 }
5531
5532 continue_loop = true;
5533 array_ctor = gfc_constructor_first (array->value.constructor);
5534 if (mask && mask->rank > 0)
5535 mask_ctor = gfc_constructor_first (mask->value.constructor);
5536 else
5537 mask_ctor = NULL;
5538
5539 /* Loop over the array elements (and mask), keeping track of
5540 the indices to return. */
5541 while (continue_loop)
5542 {
5543 do
5544 {
5545 a = array_ctor->expr;
5546 if (mask_ctor)
5547 {
5548 m = mask_ctor->expr;
5549 ma = m->value.logical;
5550 mask_ctor = gfc_constructor_next (mask_ctor);
5551 }
5552 else
5553 ma = true;
5554
5555 if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
5556 {
5557 for (i = 0; i<array->rank; i++)
5558 res[i] = count[i];
5559 if (!back_val)
5560 goto finish;
5561 }
5562 array_ctor = gfc_constructor_next (array_ctor);
5563 count[0] ++;
5564 } while (count[0] != extent[0]);
5565 n = 0;
5566 do
5567 {
5568 /* When we get to the end of a dimension, reset it and increment
5569 the next dimension. */
5570 count[n] = 0;
5571 n++;
5572 if (n >= array->rank)
5573 {
5574 continue_loop = false;
5575 break;
5576 }
5577 else
5578 count[n] ++;
5579 } while (count[n] == extent[n]);
5580 }
5581
5582 finish:
5583 result_ctor = gfc_constructor_first (result->value.constructor);
5584 for (i = 0; i<array->rank; i++)
5585 {
5586 gfc_expr *r_expr;
5587 r_expr = result_ctor->expr;
5588 mpz_set_si (r_expr->value.integer, res[i] + 1);
5589 result_ctor = gfc_constructor_next (result_ctor);
5590 }
5591 return result;
5592 }
5593
5594
5595 /* Simplify findloc to an array. Similar to
5596 simplify_minmaxloc_to_array. */
5597
5598 static gfc_expr *
5599 simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
5600 gfc_expr *dim, gfc_expr *mask, bool back_val)
5601 {
5602 mpz_t size;
5603 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
5604 gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
5605 gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
5606
5607 int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
5608 sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
5609 tmpstride[GFC_MAX_DIMENSIONS];
5610
5611 /* Shortcut for constant .FALSE. MASK. */
5612 if (mask
5613 && mask->expr_type == EXPR_CONSTANT
5614 && !mask->value.logical)
5615 return result;
5616
5617 /* Build an indexed table for array element expressions to minimize
5618 linked-list traversal. Masked elements are set to NULL. */
5619 gfc_array_size (array, &size);
5620 arraysize = mpz_get_ui (size);
5621 mpz_clear (size);
5622
5623 arrayvec = XCNEWVEC (gfc_expr*, arraysize);
5624
5625 array_ctor = gfc_constructor_first (array->value.constructor);
5626 mask_ctor = NULL;
5627 if (mask && mask->expr_type == EXPR_ARRAY)
5628 mask_ctor = gfc_constructor_first (mask->value.constructor);
5629
5630 for (i = 0; i < arraysize; ++i)
5631 {
5632 arrayvec[i] = array_ctor->expr;
5633 array_ctor = gfc_constructor_next (array_ctor);
5634
5635 if (mask_ctor)
5636 {
5637 if (!mask_ctor->expr->value.logical)
5638 arrayvec[i] = NULL;
5639
5640 mask_ctor = gfc_constructor_next (mask_ctor);
5641 }
5642 }
5643
5644 /* Same for the result expression. */
5645 gfc_array_size (result, &size);
5646 resultsize = mpz_get_ui (size);
5647 mpz_clear (size);
5648
5649 resultvec = XCNEWVEC (gfc_expr*, resultsize);
5650 result_ctor = gfc_constructor_first (result->value.constructor);
5651 for (i = 0; i < resultsize; ++i)
5652 {
5653 resultvec[i] = result_ctor->expr;
5654 result_ctor = gfc_constructor_next (result_ctor);
5655 }
5656
5657 gfc_extract_int (dim, &dim_index);
5658
5659 dim_index -= 1; /* Zero-base index. */
5660 dim_extent = 0;
5661 dim_stride = 0;
5662
5663 for (i = 0, n = 0; i < array->rank; ++i)
5664 {
5665 count[i] = 0;
5666 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
5667 if (i == dim_index)
5668 {
5669 dim_extent = mpz_get_si (array->shape[i]);
5670 dim_stride = tmpstride[i];
5671 continue;
5672 }
5673
5674 extent[n] = mpz_get_si (array->shape[i]);
5675 sstride[n] = tmpstride[i];
5676 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
5677 n += 1;
5678 }
5679
5680 done = resultsize <= 0;
5681 base = arrayvec;
5682 dest = resultvec;
5683 while (!done)
5684 {
5685 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
5686 {
5687 if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
5688 {
5689 mpz_set_si ((*dest)->value.integer, n + 1);
5690 if (!back_val)
5691 break;
5692 }
5693 }
5694
5695 count[0]++;
5696 base += sstride[0];
5697 dest += dstride[0];
5698
5699 n = 0;
5700 while (!done && count[n] == extent[n])
5701 {
5702 count[n] = 0;
5703 base -= sstride[n] * extent[n];
5704 dest -= dstride[n] * extent[n];
5705
5706 n++;
5707 if (n < result->rank)
5708 {
5709 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
5710 times, we'd warn for the last iteration, because the
5711 array index will have already been incremented to the
5712 array sizes, and we can't tell that this must make
5713 the test against result->rank false, because ranks
5714 must not exceed GFC_MAX_DIMENSIONS. */
5715 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
5716 count[n]++;
5717 base += sstride[n];
5718 dest += dstride[n];
5719 GCC_DIAGNOSTIC_POP
5720 }
5721 else
5722 done = true;
5723 }
5724 }
5725
5726 /* Place updated expression in result constructor. */
5727 result_ctor = gfc_constructor_first (result->value.constructor);
5728 for (i = 0; i < resultsize; ++i)
5729 {
5730 result_ctor->expr = resultvec[i];
5731 result_ctor = gfc_constructor_next (result_ctor);
5732 }
5733
5734 free (arrayvec);
5735 free (resultvec);
5736 return result;
5737 }
5738
5739 /* Simplify findloc. */
5740
5741 gfc_expr *
5742 gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
5743 gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
5744 {
5745 gfc_expr *result;
5746 int ikind;
5747 bool back_val = false;
5748
5749 if (!is_constant_array_expr (array)
5750 || !gfc_is_constant_expr (dim))
5751 return NULL;
5752
5753 if (! gfc_is_constant_expr (value))
5754 return 0;
5755
5756 if (mask
5757 && !is_constant_array_expr (mask)
5758 && mask->expr_type != EXPR_CONSTANT)
5759 return NULL;
5760
5761 if (kind)
5762 {
5763 if (gfc_extract_int (kind, &ikind, -1))
5764 return NULL;
5765 }
5766 else
5767 ikind = gfc_default_integer_kind;
5768
5769 if (back)
5770 {
5771 if (back->expr_type != EXPR_CONSTANT)
5772 return NULL;
5773
5774 back_val = back->value.logical;
5775 }
5776
5777 if (dim)
5778 {
5779 result = transformational_result (array, dim, BT_INTEGER,
5780 ikind, &array->where);
5781 init_result_expr (result, 0, array);
5782
5783 if (array->rank == 1)
5784 return simplify_findloc_to_scalar (result, array, value, mask,
5785 back_val);
5786 else
5787 return simplify_findloc_to_array (result, array, value, dim, mask,
5788 back_val);
5789 }
5790 else
5791 {
5792 result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
5793 return simplify_findloc_nodim (result, value, array, mask, back_val);
5794 }
5795 return NULL;
5796 }
5797
5798 gfc_expr *
5799 gfc_simplify_maxexponent (gfc_expr *x)
5800 {
5801 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5802 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
5803 gfc_real_kinds[i].max_exponent);
5804 }
5805
5806
5807 gfc_expr *
5808 gfc_simplify_minexponent (gfc_expr *x)
5809 {
5810 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5811 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
5812 gfc_real_kinds[i].min_exponent);
5813 }
5814
5815
5816 gfc_expr *
5817 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
5818 {
5819 gfc_expr *result;
5820 int kind;
5821
5822 /* First check p. */
5823 if (p->expr_type != EXPR_CONSTANT)
5824 return NULL;
5825
5826 /* p shall not be 0. */
5827 switch (p->ts.type)
5828 {
5829 case BT_INTEGER:
5830 if (mpz_cmp_ui (p->value.integer, 0) == 0)
5831 {
5832 gfc_error ("Argument %qs of MOD at %L shall not be zero",
5833 "P", &p->where);
5834 return &gfc_bad_expr;
5835 }
5836 break;
5837 case BT_REAL:
5838 if (mpfr_cmp_ui (p->value.real, 0) == 0)
5839 {
5840 gfc_error ("Argument %qs of MOD at %L shall not be zero",
5841 "P", &p->where);
5842 return &gfc_bad_expr;
5843 }
5844 break;
5845 default:
5846 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
5847 }
5848
5849 if (a->expr_type != EXPR_CONSTANT)
5850 return NULL;
5851
5852 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
5853 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
5854
5855 if (a->ts.type == BT_INTEGER)
5856 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
5857 else
5858 {
5859 gfc_set_model_kind (kind);
5860 mpfr_fmod (result->value.real, a->value.real, p->value.real,
5861 GFC_RND_MODE);
5862 }
5863
5864 return range_check (result, "MOD");
5865 }
5866
5867
5868 gfc_expr *
5869 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
5870 {
5871 gfc_expr *result;
5872 int kind;
5873
5874 /* First check p. */
5875 if (p->expr_type != EXPR_CONSTANT)
5876 return NULL;
5877
5878 /* p shall not be 0. */
5879 switch (p->ts.type)
5880 {
5881 case BT_INTEGER:
5882 if (mpz_cmp_ui (p->value.integer, 0) == 0)
5883 {
5884 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
5885 "P", &p->where);
5886 return &gfc_bad_expr;
5887 }
5888 break;
5889 case BT_REAL:
5890 if (mpfr_cmp_ui (p->value.real, 0) == 0)
5891 {
5892 gfc_error ("Argument %qs of MODULO at %L shall not be zero",
5893 "P", &p->where);
5894 return &gfc_bad_expr;
5895 }
5896 break;
5897 default:
5898 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
5899 }
5900
5901 if (a->expr_type != EXPR_CONSTANT)
5902 return NULL;
5903
5904 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
5905 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
5906
5907 if (a->ts.type == BT_INTEGER)
5908 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
5909 else
5910 {
5911 gfc_set_model_kind (kind);
5912 mpfr_fmod (result->value.real, a->value.real, p->value.real,
5913 GFC_RND_MODE);
5914 if (mpfr_cmp_ui (result->value.real, 0) != 0)
5915 {
5916 if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
5917 mpfr_add (result->value.real, result->value.real, p->value.real,
5918 GFC_RND_MODE);
5919 }
5920 else
5921 mpfr_copysign (result->value.real, result->value.real,
5922 p->value.real, GFC_RND_MODE);
5923 }
5924
5925 return range_check (result, "MODULO");
5926 }
5927
5928
5929 gfc_expr *
5930 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
5931 {
5932 gfc_expr *result;
5933 mp_exp_t emin, emax;
5934 int kind;
5935
5936 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
5937 return NULL;
5938
5939 result = gfc_copy_expr (x);
5940
5941 /* Save current values of emin and emax. */
5942 emin = mpfr_get_emin ();
5943 emax = mpfr_get_emax ();
5944
5945 /* Set emin and emax for the current model number. */
5946 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
5947 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
5948 mpfr_get_prec(result->value.real) + 1);
5949 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
5950 mpfr_check_range (result->value.real, 0, GMP_RNDU);
5951
5952 if (mpfr_sgn (s->value.real) > 0)
5953 {
5954 mpfr_nextabove (result->value.real);
5955 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
5956 }
5957 else
5958 {
5959 mpfr_nextbelow (result->value.real);
5960 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
5961 }
5962
5963 mpfr_set_emin (emin);
5964 mpfr_set_emax (emax);
5965
5966 /* Only NaN can occur. Do not use range check as it gives an
5967 error for denormal numbers. */
5968 if (mpfr_nan_p (result->value.real) && flag_range_check)
5969 {
5970 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
5971 gfc_free_expr (result);
5972 return &gfc_bad_expr;
5973 }
5974
5975 return result;
5976 }
5977
5978
5979 static gfc_expr *
5980 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
5981 {
5982 gfc_expr *itrunc, *result;
5983 int kind;
5984
5985 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
5986 if (kind == -1)
5987 return &gfc_bad_expr;
5988
5989 if (e->expr_type != EXPR_CONSTANT)
5990 return NULL;
5991
5992 itrunc = gfc_copy_expr (e);
5993 mpfr_round (itrunc->value.real, e->value.real);
5994
5995 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
5996 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
5997
5998 gfc_free_expr (itrunc);
5999
6000 return range_check (result, name);
6001 }
6002
6003
6004 gfc_expr *
6005 gfc_simplify_new_line (gfc_expr *e)
6006 {
6007 gfc_expr *result;
6008
6009 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
6010 result->value.character.string[0] = '\n';
6011
6012 return result;
6013 }
6014
6015
6016 gfc_expr *
6017 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
6018 {
6019 return simplify_nint ("NINT", e, k);
6020 }
6021
6022
6023 gfc_expr *
6024 gfc_simplify_idnint (gfc_expr *e)
6025 {
6026 return simplify_nint ("IDNINT", e, NULL);
6027 }
6028
6029
6030 static gfc_expr *
6031 add_squared (gfc_expr *result, gfc_expr *e)
6032 {
6033 mpfr_t tmp;
6034
6035 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6036 gcc_assert (result->ts.type == BT_REAL
6037 && result->expr_type == EXPR_CONSTANT);
6038
6039 gfc_set_model_kind (result->ts.kind);
6040 mpfr_init (tmp);
6041 mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
6042 mpfr_add (result->value.real, result->value.real, tmp,
6043 GFC_RND_MODE);
6044 mpfr_clear (tmp);
6045
6046 return result;
6047 }
6048
6049
6050 static gfc_expr *
6051 do_sqrt (gfc_expr *result, gfc_expr *e)
6052 {
6053 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
6054 gcc_assert (result->ts.type == BT_REAL
6055 && result->expr_type == EXPR_CONSTANT);
6056
6057 mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
6058 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6059 return result;
6060 }
6061
6062
6063 gfc_expr *
6064 gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
6065 {
6066 gfc_expr *result;
6067 bool size_zero;
6068
6069 size_zero = gfc_is_size_zero_array (e);
6070
6071 if (!(is_constant_array_expr (e) || size_zero)
6072 || (dim != NULL && !gfc_is_constant_expr (dim)))
6073 return NULL;
6074
6075 result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
6076 init_result_expr (result, 0, NULL);
6077
6078 if (size_zero)
6079 return result;
6080
6081 if (!dim || e->rank == 1)
6082 {
6083 result = simplify_transformation_to_scalar (result, e, NULL,
6084 add_squared);
6085 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
6086 }
6087 else
6088 result = simplify_transformation_to_array (result, e, dim, NULL,
6089 add_squared, &do_sqrt);
6090
6091 return result;
6092 }
6093
6094
6095 gfc_expr *
6096 gfc_simplify_not (gfc_expr *e)
6097 {
6098 gfc_expr *result;
6099
6100 if (e->expr_type != EXPR_CONSTANT)
6101 return NULL;
6102
6103 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6104 mpz_com (result->value.integer, e->value.integer);
6105
6106 return range_check (result, "NOT");
6107 }
6108
6109
6110 gfc_expr *
6111 gfc_simplify_null (gfc_expr *mold)
6112 {
6113 gfc_expr *result;
6114
6115 if (mold)
6116 {
6117 result = gfc_copy_expr (mold);
6118 result->expr_type = EXPR_NULL;
6119 }
6120 else
6121 result = gfc_get_null_expr (NULL);
6122
6123 return result;
6124 }
6125
6126
6127 gfc_expr *
6128 gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
6129 {
6130 gfc_expr *result;
6131
6132 if (flag_coarray == GFC_FCOARRAY_NONE)
6133 {
6134 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
6135 return &gfc_bad_expr;
6136 }
6137
6138 if (flag_coarray != GFC_FCOARRAY_SINGLE)
6139 return NULL;
6140
6141 if (failed && failed->expr_type != EXPR_CONSTANT)
6142 return NULL;
6143
6144 /* FIXME: gfc_current_locus is wrong. */
6145 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6146 &gfc_current_locus);
6147
6148 if (failed && failed->value.logical != 0)
6149 mpz_set_si (result->value.integer, 0);
6150 else
6151 mpz_set_si (result->value.integer, 1);
6152
6153 return result;
6154 }
6155
6156
6157 gfc_expr *
6158 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
6159 {
6160 gfc_expr *result;
6161 int kind;
6162
6163 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6164 return NULL;
6165
6166 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6167
6168 switch (x->ts.type)
6169 {
6170 case BT_INTEGER:
6171 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6172 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
6173 return range_check (result, "OR");
6174
6175 case BT_LOGICAL:
6176 return gfc_get_logical_expr (kind, &x->where,
6177 x->value.logical || y->value.logical);
6178 default:
6179 gcc_unreachable();
6180 }
6181 }
6182
6183
6184 gfc_expr *
6185 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
6186 {
6187 gfc_expr *result;
6188 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
6189
6190 if (!is_constant_array_expr (array)
6191 || !is_constant_array_expr (vector)
6192 || (!gfc_is_constant_expr (mask)
6193 && !is_constant_array_expr (mask)))
6194 return NULL;
6195
6196 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
6197 if (array->ts.type == BT_DERIVED)
6198 result->ts.u.derived = array->ts.u.derived;
6199
6200 array_ctor = gfc_constructor_first (array->value.constructor);
6201 vector_ctor = vector
6202 ? gfc_constructor_first (vector->value.constructor)
6203 : NULL;
6204
6205 if (mask->expr_type == EXPR_CONSTANT
6206 && mask->value.logical)
6207 {
6208 /* Copy all elements of ARRAY to RESULT. */
6209 while (array_ctor)
6210 {
6211 gfc_constructor_append_expr (&result->value.constructor,
6212 gfc_copy_expr (array_ctor->expr),
6213 NULL);
6214
6215 array_ctor = gfc_constructor_next (array_ctor);
6216 vector_ctor = gfc_constructor_next (vector_ctor);
6217 }
6218 }
6219 else if (mask->expr_type == EXPR_ARRAY)
6220 {
6221 /* Copy only those elements of ARRAY to RESULT whose
6222 MASK equals .TRUE.. */
6223 mask_ctor = gfc_constructor_first (mask->value.constructor);
6224 while (mask_ctor)
6225 {
6226 if (mask_ctor->expr->value.logical)
6227 {
6228 gfc_constructor_append_expr (&result->value.constructor,
6229 gfc_copy_expr (array_ctor->expr),
6230 NULL);
6231 vector_ctor = gfc_constructor_next (vector_ctor);
6232 }
6233
6234 array_ctor = gfc_constructor_next (array_ctor);
6235 mask_ctor = gfc_constructor_next (mask_ctor);
6236 }
6237 }
6238
6239 /* Append any left-over elements from VECTOR to RESULT. */
6240 while (vector_ctor)
6241 {
6242 gfc_constructor_append_expr (&result->value.constructor,
6243 gfc_copy_expr (vector_ctor->expr),
6244 NULL);
6245 vector_ctor = gfc_constructor_next (vector_ctor);
6246 }
6247
6248 result->shape = gfc_get_shape (1);
6249 gfc_array_size (result, &result->shape[0]);
6250
6251 if (array->ts.type == BT_CHARACTER)
6252 result->ts.u.cl = array->ts.u.cl;
6253
6254 return result;
6255 }
6256
6257
6258 static gfc_expr *
6259 do_xor (gfc_expr *result, gfc_expr *e)
6260 {
6261 gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
6262 gcc_assert (result->ts.type == BT_LOGICAL
6263 && result->expr_type == EXPR_CONSTANT);
6264
6265 result->value.logical = result->value.logical != e->value.logical;
6266 return result;
6267 }
6268
6269
6270
6271 gfc_expr *
6272 gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
6273 {
6274 return simplify_transformation (e, dim, NULL, 0, do_xor);
6275 }
6276
6277
6278 gfc_expr *
6279 gfc_simplify_popcnt (gfc_expr *e)
6280 {
6281 int res, k;
6282 mpz_t x;
6283
6284 if (e->expr_type != EXPR_CONSTANT)
6285 return NULL;
6286
6287 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6288
6289 /* Convert argument to unsigned, then count the '1' bits. */
6290 mpz_init_set (x, e->value.integer);
6291 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
6292 res = mpz_popcount (x);
6293 mpz_clear (x);
6294
6295 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
6296 }
6297
6298
6299 gfc_expr *
6300 gfc_simplify_poppar (gfc_expr *e)
6301 {
6302 gfc_expr *popcnt;
6303 int i;
6304
6305 if (e->expr_type != EXPR_CONSTANT)
6306 return NULL;
6307
6308 popcnt = gfc_simplify_popcnt (e);
6309 gcc_assert (popcnt);
6310
6311 bool fail = gfc_extract_int (popcnt, &i);
6312 gcc_assert (!fail);
6313
6314 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
6315 }
6316
6317
6318 gfc_expr *
6319 gfc_simplify_precision (gfc_expr *e)
6320 {
6321 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6322 return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
6323 gfc_real_kinds[i].precision);
6324 }
6325
6326
6327 gfc_expr *
6328 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
6329 {
6330 return simplify_transformation (array, dim, mask, 1, gfc_multiply);
6331 }
6332
6333
6334 gfc_expr *
6335 gfc_simplify_radix (gfc_expr *e)
6336 {
6337 int i;
6338 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6339
6340 switch (e->ts.type)
6341 {
6342 case BT_INTEGER:
6343 i = gfc_integer_kinds[i].radix;
6344 break;
6345
6346 case BT_REAL:
6347 i = gfc_real_kinds[i].radix;
6348 break;
6349
6350 default:
6351 gcc_unreachable ();
6352 }
6353
6354 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6355 }
6356
6357
6358 gfc_expr *
6359 gfc_simplify_range (gfc_expr *e)
6360 {
6361 int i;
6362 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6363
6364 switch (e->ts.type)
6365 {
6366 case BT_INTEGER:
6367 i = gfc_integer_kinds[i].range;
6368 break;
6369
6370 case BT_REAL:
6371 case BT_COMPLEX:
6372 i = gfc_real_kinds[i].range;
6373 break;
6374
6375 default:
6376 gcc_unreachable ();
6377 }
6378
6379 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
6380 }
6381
6382
6383 gfc_expr *
6384 gfc_simplify_rank (gfc_expr *e)
6385 {
6386 /* Assumed rank. */
6387 if (e->rank == -1)
6388 return NULL;
6389
6390 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
6391 }
6392
6393
6394 gfc_expr *
6395 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
6396 {
6397 gfc_expr *result = NULL;
6398 int kind;
6399
6400 if (e->ts.type == BT_COMPLEX)
6401 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
6402 else
6403 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
6404
6405 if (kind == -1)
6406 return &gfc_bad_expr;
6407
6408 if (e->expr_type != EXPR_CONSTANT)
6409 return NULL;
6410
6411 if (convert_boz (e, kind) == &gfc_bad_expr)
6412 return &gfc_bad_expr;
6413
6414 result = gfc_convert_constant (e, BT_REAL, kind);
6415 if (result == &gfc_bad_expr)
6416 return &gfc_bad_expr;
6417
6418 return range_check (result, "REAL");
6419 }
6420
6421
6422 gfc_expr *
6423 gfc_simplify_realpart (gfc_expr *e)
6424 {
6425 gfc_expr *result;
6426
6427 if (e->expr_type != EXPR_CONSTANT)
6428 return NULL;
6429
6430 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
6431 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
6432
6433 return range_check (result, "REALPART");
6434 }
6435
6436 gfc_expr *
6437 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
6438 {
6439 gfc_expr *result;
6440 gfc_charlen_t len;
6441 mpz_t ncopies;
6442 bool have_length = false;
6443
6444 /* If NCOPIES isn't a constant, there's nothing we can do. */
6445 if (n->expr_type != EXPR_CONSTANT)
6446 return NULL;
6447
6448 /* If NCOPIES is negative, it's an error. */
6449 if (mpz_sgn (n->value.integer) < 0)
6450 {
6451 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
6452 &n->where);
6453 return &gfc_bad_expr;
6454 }
6455
6456 /* If we don't know the character length, we can do no more. */
6457 if (e->ts.u.cl && e->ts.u.cl->length
6458 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6459 {
6460 len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer);
6461 have_length = true;
6462 }
6463 else if (e->expr_type == EXPR_CONSTANT
6464 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
6465 {
6466 len = e->value.character.length;
6467 }
6468 else
6469 return NULL;
6470
6471 /* If the source length is 0, any value of NCOPIES is valid
6472 and everything behaves as if NCOPIES == 0. */
6473 mpz_init (ncopies);
6474 if (len == 0)
6475 mpz_set_ui (ncopies, 0);
6476 else
6477 mpz_set (ncopies, n->value.integer);
6478
6479 /* Check that NCOPIES isn't too large. */
6480 if (len)
6481 {
6482 mpz_t max, mlen;
6483 int i;
6484
6485 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
6486 mpz_init (max);
6487 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
6488
6489 if (have_length)
6490 {
6491 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
6492 e->ts.u.cl->length->value.integer);
6493 }
6494 else
6495 {
6496 mpz_init (mlen);
6497 gfc_mpz_set_hwi (mlen, len);
6498 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
6499 mpz_clear (mlen);
6500 }
6501
6502 /* The check itself. */
6503 if (mpz_cmp (ncopies, max) > 0)
6504 {
6505 mpz_clear (max);
6506 mpz_clear (ncopies);
6507 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
6508 &n->where);
6509 return &gfc_bad_expr;
6510 }
6511
6512 mpz_clear (max);
6513 }
6514 mpz_clear (ncopies);
6515
6516 /* For further simplification, we need the character string to be
6517 constant. */
6518 if (e->expr_type != EXPR_CONSTANT)
6519 return NULL;
6520
6521 HOST_WIDE_INT ncop;
6522 if (len ||
6523 (e->ts.u.cl->length &&
6524 mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
6525 {
6526 bool fail = gfc_extract_hwi (n, &ncop);
6527 gcc_assert (!fail);
6528 }
6529 else
6530 ncop = 0;
6531
6532 if (ncop == 0)
6533 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
6534
6535 len = e->value.character.length;
6536 gfc_charlen_t nlen = ncop * len;
6537
6538 /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
6539 (2**28 elements * 4 bytes (wide chars) per element) defer to
6540 runtime instead of consuming (unbounded) memory and CPU at
6541 compile time. */
6542 if (nlen > 268435456)
6543 {
6544 gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
6545 " deferred to runtime, expect bugs", &e->where);
6546 return NULL;
6547 }
6548
6549 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
6550 for (size_t i = 0; i < (size_t) ncop; i++)
6551 for (size_t j = 0; j < (size_t) len; j++)
6552 result->value.character.string[j+i*len]= e->value.character.string[j];
6553
6554 result->value.character.string[nlen] = '\0'; /* For debugger */
6555 return result;
6556 }
6557
6558
6559 /* This one is a bear, but mainly has to do with shuffling elements. */
6560
6561 gfc_expr *
6562 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
6563 gfc_expr *pad, gfc_expr *order_exp)
6564 {
6565 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
6566 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
6567 mpz_t index, size;
6568 unsigned long j;
6569 size_t nsource;
6570 gfc_expr *e, *result;
6571
6572 /* Check that argument expression types are OK. */
6573 if (!is_constant_array_expr (source)
6574 || !is_constant_array_expr (shape_exp)
6575 || !is_constant_array_expr (pad)
6576 || !is_constant_array_expr (order_exp))
6577 return NULL;
6578
6579 if (source->shape == NULL)
6580 return NULL;
6581
6582 /* Proceed with simplification, unpacking the array. */
6583
6584 mpz_init (index);
6585 rank = 0;
6586
6587 for (;;)
6588 {
6589 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
6590 if (e == NULL)
6591 break;
6592
6593 gfc_extract_int (e, &shape[rank]);
6594
6595 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
6596 gcc_assert (shape[rank] >= 0);
6597
6598 rank++;
6599 }
6600
6601 gcc_assert (rank > 0);
6602
6603 /* Now unpack the order array if present. */
6604 if (order_exp == NULL)
6605 {
6606 for (i = 0; i < rank; i++)
6607 order[i] = i;
6608 }
6609 else
6610 {
6611 for (i = 0; i < rank; i++)
6612 x[i] = 0;
6613
6614 for (i = 0; i < rank; i++)
6615 {
6616 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
6617 gcc_assert (e);
6618
6619 gfc_extract_int (e, &order[i]);
6620
6621 gcc_assert (order[i] >= 1 && order[i] <= rank);
6622 order[i]--;
6623 gcc_assert (x[order[i]] == 0);
6624 x[order[i]] = 1;
6625 }
6626 }
6627
6628 /* Count the elements in the source and padding arrays. */
6629
6630 npad = 0;
6631 if (pad != NULL)
6632 {
6633 gfc_array_size (pad, &size);
6634 npad = mpz_get_ui (size);
6635 mpz_clear (size);
6636 }
6637
6638 gfc_array_size (source, &size);
6639 nsource = mpz_get_ui (size);
6640 mpz_clear (size);
6641
6642 /* If it weren't for that pesky permutation we could just loop
6643 through the source and round out any shortage with pad elements.
6644 But no, someone just had to have the compiler do something the
6645 user should be doing. */
6646
6647 for (i = 0; i < rank; i++)
6648 x[i] = 0;
6649
6650 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
6651 &source->where);
6652 if (source->ts.type == BT_DERIVED)
6653 result->ts.u.derived = source->ts.u.derived;
6654 result->rank = rank;
6655 result->shape = gfc_get_shape (rank);
6656 for (i = 0; i < rank; i++)
6657 mpz_init_set_ui (result->shape[i], shape[i]);
6658
6659 while (nsource > 0 || npad > 0)
6660 {
6661 /* Figure out which element to extract. */
6662 mpz_set_ui (index, 0);
6663
6664 for (i = rank - 1; i >= 0; i--)
6665 {
6666 mpz_add_ui (index, index, x[order[i]]);
6667 if (i != 0)
6668 mpz_mul_ui (index, index, shape[order[i - 1]]);
6669 }
6670
6671 if (mpz_cmp_ui (index, INT_MAX) > 0)
6672 gfc_internal_error ("Reshaped array too large at %C");
6673
6674 j = mpz_get_ui (index);
6675
6676 if (j < nsource)
6677 e = gfc_constructor_lookup_expr (source->value.constructor, j);
6678 else
6679 {
6680 if (npad <= 0)
6681 {
6682 mpz_clear (index);
6683 return NULL;
6684 }
6685 j = j - nsource;
6686 j = j % npad;
6687 e = gfc_constructor_lookup_expr (pad->value.constructor, j);
6688 }
6689 gcc_assert (e);
6690
6691 gfc_constructor_append_expr (&result->value.constructor,
6692 gfc_copy_expr (e), &e->where);
6693
6694 /* Calculate the next element. */
6695 i = 0;
6696
6697 inc:
6698 if (++x[i] < shape[i])
6699 continue;
6700 x[i++] = 0;
6701 if (i < rank)
6702 goto inc;
6703
6704 break;
6705 }
6706
6707 mpz_clear (index);
6708
6709 return result;
6710 }
6711
6712
6713 gfc_expr *
6714 gfc_simplify_rrspacing (gfc_expr *x)
6715 {
6716 gfc_expr *result;
6717 int i;
6718 long int e, p;
6719
6720 if (x->expr_type != EXPR_CONSTANT)
6721 return NULL;
6722
6723 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6724
6725 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
6726
6727 /* RRSPACING(+/- 0.0) = 0.0 */
6728 if (mpfr_zero_p (x->value.real))
6729 {
6730 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
6731 return result;
6732 }
6733
6734 /* RRSPACING(inf) = NaN */
6735 if (mpfr_inf_p (x->value.real))
6736 {
6737 mpfr_set_nan (result->value.real);
6738 return result;
6739 }
6740
6741 /* RRSPACING(NaN) = same NaN */
6742 if (mpfr_nan_p (x->value.real))
6743 {
6744 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
6745 return result;
6746 }
6747
6748 /* | x * 2**(-e) | * 2**p. */
6749 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
6750 e = - (long int) mpfr_get_exp (x->value.real);
6751 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
6752
6753 p = (long int) gfc_real_kinds[i].digits;
6754 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
6755
6756 return range_check (result, "RRSPACING");
6757 }
6758
6759
6760 gfc_expr *
6761 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
6762 {
6763 int k, neg_flag, power, exp_range;
6764 mpfr_t scale, radix;
6765 gfc_expr *result;
6766
6767 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
6768 return NULL;
6769
6770 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
6771
6772 if (mpfr_zero_p (x->value.real))
6773 {
6774 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
6775 return result;
6776 }
6777
6778 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
6779
6780 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
6781
6782 /* This check filters out values of i that would overflow an int. */
6783 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
6784 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
6785 {
6786 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
6787 gfc_free_expr (result);
6788 return &gfc_bad_expr;
6789 }
6790
6791 /* Compute scale = radix ** power. */
6792 power = mpz_get_si (i->value.integer);
6793
6794 if (power >= 0)
6795 neg_flag = 0;
6796 else
6797 {
6798 neg_flag = 1;
6799 power = -power;
6800 }
6801
6802 gfc_set_model_kind (x->ts.kind);
6803 mpfr_init (scale);
6804 mpfr_init (radix);
6805 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
6806 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
6807
6808 if (neg_flag)
6809 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
6810 else
6811 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
6812
6813 mpfr_clears (scale, radix, NULL);
6814
6815 return range_check (result, "SCALE");
6816 }
6817
6818
6819 /* Variants of strspn and strcspn that operate on wide characters. */
6820
6821 static size_t
6822 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
6823 {
6824 size_t i = 0;
6825 const gfc_char_t *c;
6826
6827 while (s1[i])
6828 {
6829 for (c = s2; *c; c++)
6830 {
6831 if (s1[i] == *c)
6832 break;
6833 }
6834 if (*c == '\0')
6835 break;
6836 i++;
6837 }
6838
6839 return i;
6840 }
6841
6842 static size_t
6843 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
6844 {
6845 size_t i = 0;
6846 const gfc_char_t *c;
6847
6848 while (s1[i])
6849 {
6850 for (c = s2; *c; c++)
6851 {
6852 if (s1[i] == *c)
6853 break;
6854 }
6855 if (*c)
6856 break;
6857 i++;
6858 }
6859
6860 return i;
6861 }
6862
6863
6864 gfc_expr *
6865 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
6866 {
6867 gfc_expr *result;
6868 int back;
6869 size_t i;
6870 size_t indx, len, lenc;
6871 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
6872
6873 if (k == -1)
6874 return &gfc_bad_expr;
6875
6876 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
6877 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
6878 return NULL;
6879
6880 if (b != NULL && b->value.logical != 0)
6881 back = 1;
6882 else
6883 back = 0;
6884
6885 len = e->value.character.length;
6886 lenc = c->value.character.length;
6887
6888 if (len == 0 || lenc == 0)
6889 {
6890 indx = 0;
6891 }
6892 else
6893 {
6894 if (back == 0)
6895 {
6896 indx = wide_strcspn (e->value.character.string,
6897 c->value.character.string) + 1;
6898 if (indx > len)
6899 indx = 0;
6900 }
6901 else
6902 {
6903 i = 0;
6904 for (indx = len; indx > 0; indx--)
6905 {
6906 for (i = 0; i < lenc; i++)
6907 {
6908 if (c->value.character.string[i]
6909 == e->value.character.string[indx - 1])
6910 break;
6911 }
6912 if (i < lenc)
6913 break;
6914 }
6915 }
6916 }
6917
6918 result = gfc_get_int_expr (k, &e->where, indx);
6919 return range_check (result, "SCAN");
6920 }
6921
6922
6923 gfc_expr *
6924 gfc_simplify_selected_char_kind (gfc_expr *e)
6925 {
6926 int kind;
6927
6928 if (e->expr_type != EXPR_CONSTANT)
6929 return NULL;
6930
6931 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
6932 || gfc_compare_with_Cstring (e, "default", false) == 0)
6933 kind = 1;
6934 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
6935 kind = 4;
6936 else
6937 kind = -1;
6938
6939 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
6940 }
6941
6942
6943 gfc_expr *
6944 gfc_simplify_selected_int_kind (gfc_expr *e)
6945 {
6946 int i, kind, range;
6947
6948 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
6949 return NULL;
6950
6951 kind = INT_MAX;
6952
6953 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
6954 if (gfc_integer_kinds[i].range >= range
6955 && gfc_integer_kinds[i].kind < kind)
6956 kind = gfc_integer_kinds[i].kind;
6957
6958 if (kind == INT_MAX)
6959 kind = -1;
6960
6961 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
6962 }
6963
6964
6965 gfc_expr *
6966 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
6967 {
6968 int range, precision, radix, i, kind, found_precision, found_range,
6969 found_radix;
6970 locus *loc = &gfc_current_locus;
6971
6972 if (p == NULL)
6973 precision = 0;
6974 else
6975 {
6976 if (p->expr_type != EXPR_CONSTANT
6977 || gfc_extract_int (p, &precision))
6978 return NULL;
6979 loc = &p->where;
6980 }
6981
6982 if (q == NULL)
6983 range = 0;
6984 else
6985 {
6986 if (q->expr_type != EXPR_CONSTANT
6987 || gfc_extract_int (q, &range))
6988 return NULL;
6989
6990 if (!loc)
6991 loc = &q->where;
6992 }
6993
6994 if (rdx == NULL)
6995 radix = 0;
6996 else
6997 {
6998 if (rdx->expr_type != EXPR_CONSTANT
6999 || gfc_extract_int (rdx, &radix))
7000 return NULL;
7001
7002 if (!loc)
7003 loc = &rdx->where;
7004 }
7005
7006 kind = INT_MAX;
7007 found_precision = 0;
7008 found_range = 0;
7009 found_radix = 0;
7010
7011 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
7012 {
7013 if (gfc_real_kinds[i].precision >= precision)
7014 found_precision = 1;
7015
7016 if (gfc_real_kinds[i].range >= range)
7017 found_range = 1;
7018
7019 if (radix == 0 || gfc_real_kinds[i].radix == radix)
7020 found_radix = 1;
7021
7022 if (gfc_real_kinds[i].precision >= precision
7023 && gfc_real_kinds[i].range >= range
7024 && (radix == 0 || gfc_real_kinds[i].radix == radix)
7025 && gfc_real_kinds[i].kind < kind)
7026 kind = gfc_real_kinds[i].kind;
7027 }
7028
7029 if (kind == INT_MAX)
7030 {
7031 if (found_radix && found_range && !found_precision)
7032 kind = -1;
7033 else if (found_radix && found_precision && !found_range)
7034 kind = -2;
7035 else if (found_radix && !found_precision && !found_range)
7036 kind = -3;
7037 else if (found_radix)
7038 kind = -4;
7039 else
7040 kind = -5;
7041 }
7042
7043 return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
7044 }
7045
7046
7047 gfc_expr *
7048 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
7049 {
7050 gfc_expr *result;
7051 mpfr_t exp, absv, log2, pow2, frac;
7052 unsigned long exp2;
7053
7054 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
7055 return NULL;
7056
7057 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7058
7059 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
7060 SET_EXPONENT (NaN) = same NaN */
7061 if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real))
7062 {
7063 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7064 return result;
7065 }
7066
7067 /* SET_EXPONENT (inf) = NaN */
7068 if (mpfr_inf_p (x->value.real))
7069 {
7070 mpfr_set_nan (result->value.real);
7071 return result;
7072 }
7073
7074 gfc_set_model_kind (x->ts.kind);
7075 mpfr_init (absv);
7076 mpfr_init (log2);
7077 mpfr_init (exp);
7078 mpfr_init (pow2);
7079 mpfr_init (frac);
7080
7081 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
7082 mpfr_log2 (log2, absv, GFC_RND_MODE);
7083
7084 mpfr_trunc (log2, log2);
7085 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
7086
7087 /* Old exponent value, and fraction. */
7088 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
7089
7090 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
7091
7092 /* New exponent. */
7093 exp2 = (unsigned long) mpz_get_d (i->value.integer);
7094 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
7095
7096 mpfr_clears (absv, log2, pow2, frac, NULL);
7097
7098 return range_check (result, "SET_EXPONENT");
7099 }
7100
7101
7102 gfc_expr *
7103 gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
7104 {
7105 mpz_t shape[GFC_MAX_DIMENSIONS];
7106 gfc_expr *result, *e, *f;
7107 gfc_array_ref *ar;
7108 int n;
7109 bool t;
7110 int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
7111
7112 if (source->rank == -1)
7113 return NULL;
7114
7115 result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
7116
7117 if (source->rank == 0)
7118 return result;
7119
7120 if (source->expr_type == EXPR_VARIABLE)
7121 {
7122 ar = gfc_find_array_ref (source);
7123 t = gfc_array_ref_shape (ar, shape);
7124 }
7125 else if (source->shape)
7126 {
7127 t = true;
7128 for (n = 0; n < source->rank; n++)
7129 {
7130 mpz_init (shape[n]);
7131 mpz_set (shape[n], source->shape[n]);
7132 }
7133 }
7134 else
7135 t = false;
7136
7137 for (n = 0; n < source->rank; n++)
7138 {
7139 e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
7140
7141 if (t)
7142 mpz_set (e->value.integer, shape[n]);
7143 else
7144 {
7145 mpz_set_ui (e->value.integer, n + 1);
7146
7147 f = simplify_size (source, e, k);
7148 gfc_free_expr (e);
7149 if (f == NULL)
7150 {
7151 gfc_free_expr (result);
7152 return NULL;
7153 }
7154 else
7155 e = f;
7156 }
7157
7158 if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
7159 {
7160 gfc_free_expr (result);
7161 if (t)
7162 gfc_clear_shape (shape, source->rank);
7163 return &gfc_bad_expr;
7164 }
7165
7166 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
7167 }
7168
7169 if (t)
7170 gfc_clear_shape (shape, source->rank);
7171
7172 return result;
7173 }
7174
7175
7176 static gfc_expr *
7177 simplify_size (gfc_expr *array, gfc_expr *dim, int k)
7178 {
7179 mpz_t size;
7180 gfc_expr *return_value;
7181 int d;
7182
7183 /* For unary operations, the size of the result is given by the size
7184 of the operand. For binary ones, it's the size of the first operand
7185 unless it is scalar, then it is the size of the second. */
7186 if (array->expr_type == EXPR_OP && !array->value.op.uop)
7187 {
7188 gfc_expr* replacement;
7189 gfc_expr* simplified;
7190
7191 switch (array->value.op.op)
7192 {
7193 /* Unary operations. */
7194 case INTRINSIC_NOT:
7195 case INTRINSIC_UPLUS:
7196 case INTRINSIC_UMINUS:
7197 case INTRINSIC_PARENTHESES:
7198 replacement = array->value.op.op1;
7199 break;
7200
7201 /* Binary operations. If any one of the operands is scalar, take
7202 the other one's size. If both of them are arrays, it does not
7203 matter -- try to find one with known shape, if possible. */
7204 default:
7205 if (array->value.op.op1->rank == 0)
7206 replacement = array->value.op.op2;
7207 else if (array->value.op.op2->rank == 0)
7208 replacement = array->value.op.op1;
7209 else
7210 {
7211 simplified = simplify_size (array->value.op.op1, dim, k);
7212 if (simplified)
7213 return simplified;
7214
7215 replacement = array->value.op.op2;
7216 }
7217 break;
7218 }
7219
7220 /* Try to reduce it directly if possible. */
7221 simplified = simplify_size (replacement, dim, k);
7222
7223 /* Otherwise, we build a new SIZE call. This is hopefully at least
7224 simpler than the original one. */
7225 if (!simplified)
7226 {
7227 gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
7228 simplified = gfc_build_intrinsic_call (gfc_current_ns,
7229 GFC_ISYM_SIZE, "size",
7230 array->where, 3,
7231 gfc_copy_expr (replacement),
7232 gfc_copy_expr (dim),
7233 kind);
7234 }
7235 return simplified;
7236 }
7237
7238 if (dim == NULL)
7239 {
7240 if (!gfc_array_size (array, &size))
7241 return NULL;
7242 }
7243 else
7244 {
7245 if (dim->expr_type != EXPR_CONSTANT)
7246 return NULL;
7247
7248 d = mpz_get_ui (dim->value.integer) - 1;
7249 if (!gfc_array_dimen_size (array, d, &size))
7250 return NULL;
7251 }
7252
7253 return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
7254 mpz_set (return_value->value.integer, size);
7255 mpz_clear (size);
7256
7257 return return_value;
7258 }
7259
7260
7261 gfc_expr *
7262 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
7263 {
7264 gfc_expr *result;
7265 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
7266
7267 if (k == -1)
7268 return &gfc_bad_expr;
7269
7270 result = simplify_size (array, dim, k);
7271 if (result == NULL || result == &gfc_bad_expr)
7272 return result;
7273
7274 return range_check (result, "SIZE");
7275 }
7276
7277
7278 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
7279 multiplied by the array size. */
7280
7281 gfc_expr *
7282 gfc_simplify_sizeof (gfc_expr *x)
7283 {
7284 gfc_expr *result = NULL;
7285 mpz_t array_size;
7286
7287 if (x->ts.type == BT_CLASS || x->ts.deferred)
7288 return NULL;
7289
7290 if (x->ts.type == BT_CHARACTER
7291 && (!x->ts.u.cl || !x->ts.u.cl->length
7292 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
7293 return NULL;
7294
7295 if (x->rank && x->expr_type != EXPR_ARRAY
7296 && !gfc_array_size (x, &array_size))
7297 return NULL;
7298
7299 result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
7300 &x->where);
7301 mpz_set_si (result->value.integer, gfc_target_expr_size (x));
7302
7303 return result;
7304 }
7305
7306
7307 /* STORAGE_SIZE returns the size in bits of a single array element. */
7308
7309 gfc_expr *
7310 gfc_simplify_storage_size (gfc_expr *x,
7311 gfc_expr *kind)
7312 {
7313 gfc_expr *result = NULL;
7314 int k;
7315
7316 if (x->ts.type == BT_CLASS || x->ts.deferred)
7317 return NULL;
7318
7319 if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
7320 && (!x->ts.u.cl || !x->ts.u.cl->length
7321 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
7322 return NULL;
7323
7324 k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
7325 if (k == -1)
7326 return &gfc_bad_expr;
7327
7328 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
7329
7330 mpz_set_si (result->value.integer, gfc_element_size (x));
7331 mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
7332
7333 return range_check (result, "STORAGE_SIZE");
7334 }
7335
7336
7337 gfc_expr *
7338 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
7339 {
7340 gfc_expr *result;
7341
7342 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
7343 return NULL;
7344
7345 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7346
7347 switch (x->ts.type)
7348 {
7349 case BT_INTEGER:
7350 mpz_abs (result->value.integer, x->value.integer);
7351 if (mpz_sgn (y->value.integer) < 0)
7352 mpz_neg (result->value.integer, result->value.integer);
7353 break;
7354
7355 case BT_REAL:
7356 if (flag_sign_zero)
7357 mpfr_copysign (result->value.real, x->value.real, y->value.real,
7358 GFC_RND_MODE);
7359 else
7360 mpfr_setsign (result->value.real, x->value.real,
7361 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
7362 break;
7363
7364 default:
7365 gfc_internal_error ("Bad type in gfc_simplify_sign");
7366 }
7367
7368 return result;
7369 }
7370
7371
7372 gfc_expr *
7373 gfc_simplify_sin (gfc_expr *x)
7374 {
7375 gfc_expr *result;
7376
7377 if (x->expr_type != EXPR_CONSTANT)
7378 return NULL;
7379
7380 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7381
7382 switch (x->ts.type)
7383 {
7384 case BT_REAL:
7385 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
7386 break;
7387
7388 case BT_COMPLEX:
7389 gfc_set_model (x->value.real);
7390 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
7391 break;
7392
7393 default:
7394 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
7395 }
7396
7397 return range_check (result, "SIN");
7398 }
7399
7400
7401 gfc_expr *
7402 gfc_simplify_sinh (gfc_expr *x)
7403 {
7404 gfc_expr *result;
7405
7406 if (x->expr_type != EXPR_CONSTANT)
7407 return NULL;
7408
7409 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7410
7411 switch (x->ts.type)
7412 {
7413 case BT_REAL:
7414 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
7415 break;
7416
7417 case BT_COMPLEX:
7418 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
7419 break;
7420
7421 default:
7422 gcc_unreachable ();
7423 }
7424
7425 return range_check (result, "SINH");
7426 }
7427
7428
7429 /* The argument is always a double precision real that is converted to
7430 single precision. TODO: Rounding! */
7431
7432 gfc_expr *
7433 gfc_simplify_sngl (gfc_expr *a)
7434 {
7435 gfc_expr *result;
7436
7437 if (a->expr_type != EXPR_CONSTANT)
7438 return NULL;
7439
7440 result = gfc_real2real (a, gfc_default_real_kind);
7441 return range_check (result, "SNGL");
7442 }
7443
7444
7445 gfc_expr *
7446 gfc_simplify_spacing (gfc_expr *x)
7447 {
7448 gfc_expr *result;
7449 int i;
7450 long int en, ep;
7451
7452 if (x->expr_type != EXPR_CONSTANT)
7453 return NULL;
7454
7455 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
7456 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
7457
7458 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
7459 if (mpfr_zero_p (x->value.real))
7460 {
7461 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
7462 return result;
7463 }
7464
7465 /* SPACING(inf) = NaN */
7466 if (mpfr_inf_p (x->value.real))
7467 {
7468 mpfr_set_nan (result->value.real);
7469 return result;
7470 }
7471
7472 /* SPACING(NaN) = same NaN */
7473 if (mpfr_nan_p (x->value.real))
7474 {
7475 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
7476 return result;
7477 }
7478
7479 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
7480 are the radix, exponent of x, and precision. This excludes the
7481 possibility of subnormal numbers. Fortran 2003 states the result is
7482 b**max(e - p, emin - 1). */
7483
7484 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
7485 en = (long int) gfc_real_kinds[i].min_exponent - 1;
7486 en = en > ep ? en : ep;
7487
7488 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
7489 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
7490
7491 return range_check (result, "SPACING");
7492 }
7493
7494
7495 gfc_expr *
7496 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
7497 {
7498 gfc_expr *result = NULL;
7499 int nelem, i, j, dim, ncopies;
7500 mpz_t size;
7501
7502 if ((!gfc_is_constant_expr (source)
7503 && !is_constant_array_expr (source))
7504 || !gfc_is_constant_expr (dim_expr)
7505 || !gfc_is_constant_expr (ncopies_expr))
7506 return NULL;
7507
7508 gcc_assert (dim_expr->ts.type == BT_INTEGER);
7509 gfc_extract_int (dim_expr, &dim);
7510 dim -= 1; /* zero-base DIM */
7511
7512 gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
7513 gfc_extract_int (ncopies_expr, &ncopies);
7514 ncopies = MAX (ncopies, 0);
7515
7516 /* Do not allow the array size to exceed the limit for an array
7517 constructor. */
7518 if (source->expr_type == EXPR_ARRAY)
7519 {
7520 if (!gfc_array_size (source, &size))
7521 gfc_internal_error ("Failure getting length of a constant array.");
7522 }
7523 else
7524 mpz_init_set_ui (size, 1);
7525
7526 nelem = mpz_get_si (size) * ncopies;
7527 if (nelem > flag_max_array_constructor)
7528 {
7529 if (gfc_current_ns->sym_root->n.sym->attr.flavor == FL_PARAMETER)
7530 {
7531 gfc_error ("The number of elements (%d) in the array constructor "
7532 "at %L requires an increase of the allowed %d upper "
7533 "limit. See %<-fmax-array-constructor%> option.",
7534 nelem, &source->where, flag_max_array_constructor);
7535 return &gfc_bad_expr;
7536 }
7537 else
7538 return NULL;
7539 }
7540
7541 if (source->expr_type == EXPR_CONSTANT)
7542 {
7543 gcc_assert (dim == 0);
7544
7545 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
7546 &source->where);
7547 if (source->ts.type == BT_DERIVED)
7548 result->ts.u.derived = source->ts.u.derived;
7549 result->rank = 1;
7550 result->shape = gfc_get_shape (result->rank);
7551 mpz_init_set_si (result->shape[0], ncopies);
7552
7553 for (i = 0; i < ncopies; ++i)
7554 gfc_constructor_append_expr (&result->value.constructor,
7555 gfc_copy_expr (source), NULL);
7556 }
7557 else if (source->expr_type == EXPR_ARRAY)
7558 {
7559 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
7560 gfc_constructor *source_ctor;
7561
7562 gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
7563 gcc_assert (dim >= 0 && dim <= source->rank);
7564
7565 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
7566 &source->where);
7567 if (source->ts.type == BT_DERIVED)
7568 result->ts.u.derived = source->ts.u.derived;
7569 result->rank = source->rank + 1;
7570 result->shape = gfc_get_shape (result->rank);
7571
7572 for (i = 0, j = 0; i < result->rank; ++i)
7573 {
7574 if (i != dim)
7575 mpz_init_set (result->shape[i], source->shape[j++]);
7576 else
7577 mpz_init_set_si (result->shape[i], ncopies);
7578
7579 extent[i] = mpz_get_si (result->shape[i]);
7580 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
7581 }
7582
7583 offset = 0;
7584 for (source_ctor = gfc_constructor_first (source->value.constructor);
7585 source_ctor; source_ctor = gfc_constructor_next (source_ctor))
7586 {
7587 for (i = 0; i < ncopies; ++i)
7588 gfc_constructor_insert_expr (&result->value.constructor,
7589 gfc_copy_expr (source_ctor->expr),
7590 NULL, offset + i * rstride[dim]);
7591
7592 offset += (dim == 0 ? ncopies : 1);
7593 }
7594 }
7595 else
7596 {
7597 gfc_error ("Simplification of SPREAD at %C not yet implemented");
7598 return &gfc_bad_expr;
7599 }
7600
7601 if (source->ts.type == BT_CHARACTER)
7602 result->ts.u.cl = source->ts.u.cl;
7603
7604 return result;
7605 }
7606
7607
7608 gfc_expr *
7609 gfc_simplify_sqrt (gfc_expr *e)
7610 {
7611 gfc_expr *result = NULL;
7612
7613 if (e->expr_type != EXPR_CONSTANT)
7614 return NULL;
7615
7616 switch (e->ts.type)
7617 {
7618 case BT_REAL:
7619 if (mpfr_cmp_si (e->value.real, 0) < 0)
7620 {
7621 gfc_error ("Argument of SQRT at %L has a negative value",
7622 &e->where);
7623 return &gfc_bad_expr;
7624 }
7625 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
7626 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
7627 break;
7628
7629 case BT_COMPLEX:
7630 gfc_set_model (e->value.real);
7631
7632 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
7633 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
7634 break;
7635
7636 default:
7637 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
7638 }
7639
7640 return range_check (result, "SQRT");
7641 }
7642
7643
7644 gfc_expr *
7645 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
7646 {
7647 return simplify_transformation (array, dim, mask, 0, gfc_add);
7648 }
7649
7650
7651 gfc_expr *
7652 gfc_simplify_cotan (gfc_expr *x)
7653 {
7654 gfc_expr *result;
7655 mpc_t swp, *val;
7656
7657 if (x->expr_type != EXPR_CONSTANT)
7658 return NULL;
7659
7660 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7661
7662 switch (x->ts.type)
7663 {
7664 case BT_REAL:
7665 mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE);
7666 break;
7667
7668 case BT_COMPLEX:
7669 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
7670 val = &result->value.complex;
7671 mpc_init2 (swp, mpfr_get_default_prec ());
7672 mpc_cos (swp, x->value.complex, GFC_MPC_RND_MODE);
7673 mpc_sin (*val, x->value.complex, GFC_MPC_RND_MODE);
7674 mpc_div (*val, swp, *val, GFC_MPC_RND_MODE);
7675 mpc_clear (swp);
7676 break;
7677
7678 default:
7679 gcc_unreachable ();
7680 }
7681
7682 return range_check (result, "COTAN");
7683 }
7684
7685
7686 gfc_expr *
7687 gfc_simplify_tan (gfc_expr *x)
7688 {
7689 gfc_expr *result;
7690
7691 if (x->expr_type != EXPR_CONSTANT)
7692 return NULL;
7693
7694 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7695
7696 switch (x->ts.type)
7697 {
7698 case BT_REAL:
7699 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
7700 break;
7701
7702 case BT_COMPLEX:
7703 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
7704 break;
7705
7706 default:
7707 gcc_unreachable ();
7708 }
7709
7710 return range_check (result, "TAN");
7711 }
7712
7713
7714 gfc_expr *
7715 gfc_simplify_tanh (gfc_expr *x)
7716 {
7717 gfc_expr *result;
7718
7719 if (x->expr_type != EXPR_CONSTANT)
7720 return NULL;
7721
7722 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
7723
7724 switch (x->ts.type)
7725 {
7726 case BT_REAL:
7727 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
7728 break;
7729
7730 case BT_COMPLEX:
7731 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
7732 break;
7733
7734 default:
7735 gcc_unreachable ();
7736 }
7737
7738 return range_check (result, "TANH");
7739 }
7740
7741
7742 gfc_expr *
7743 gfc_simplify_tiny (gfc_expr *e)
7744 {
7745 gfc_expr *result;
7746 int i;
7747
7748 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
7749
7750 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
7751 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
7752
7753 return result;
7754 }
7755
7756
7757 gfc_expr *
7758 gfc_simplify_trailz (gfc_expr *e)
7759 {
7760 unsigned long tz, bs;
7761 int i;
7762
7763 if (e->expr_type != EXPR_CONSTANT)
7764 return NULL;
7765
7766 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
7767 bs = gfc_integer_kinds[i].bit_size;
7768 tz = mpz_scan1 (e->value.integer, 0);
7769
7770 return gfc_get_int_expr (gfc_default_integer_kind,
7771 &e->where, MIN (tz, bs));
7772 }
7773
7774
7775 gfc_expr *
7776 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
7777 {
7778 gfc_expr *result;
7779 gfc_expr *mold_element;
7780 size_t source_size;
7781 size_t result_size;
7782 size_t buffer_size;
7783 mpz_t tmp;
7784 unsigned char *buffer;
7785 size_t result_length;
7786
7787 if (!gfc_is_constant_expr (source) || !gfc_is_constant_expr (size))
7788 return NULL;
7789
7790 if (!gfc_resolve_expr (mold))
7791 return NULL;
7792 if (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
7793 return NULL;
7794
7795 if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
7796 &result_size, &result_length))
7797 return NULL;
7798
7799 /* Calculate the size of the source. */
7800 if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp))
7801 gfc_internal_error ("Failure getting length of a constant array.");
7802
7803 /* Create an empty new expression with the appropriate characteristics. */
7804 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
7805 &source->where);
7806 result->ts = mold->ts;
7807
7808 mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor)
7809 ? gfc_constructor_first (mold->value.constructor)->expr
7810 : mold;
7811
7812 /* Set result character length, if needed. Note that this needs to be
7813 set even for array expressions, in order to pass this information into
7814 gfc_target_interpret_expr. */
7815 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
7816 result->value.character.length = mold_element->value.character.length;
7817
7818 /* Set the number of elements in the result, and determine its size. */
7819
7820 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
7821 {
7822 result->expr_type = EXPR_ARRAY;
7823 result->rank = 1;
7824 result->shape = gfc_get_shape (1);
7825 mpz_init_set_ui (result->shape[0], result_length);
7826 }
7827 else
7828 result->rank = 0;
7829
7830 /* Allocate the buffer to store the binary version of the source. */
7831 buffer_size = MAX (source_size, result_size);
7832 buffer = (unsigned char*)alloca (buffer_size);
7833 memset (buffer, 0, buffer_size);
7834
7835 /* Now write source to the buffer. */
7836 gfc_target_encode_expr (source, buffer, buffer_size);
7837
7838 /* And read the buffer back into the new expression. */
7839 gfc_target_interpret_expr (buffer, buffer_size, result, false);
7840
7841 return result;
7842 }
7843
7844
7845 gfc_expr *
7846 gfc_simplify_transpose (gfc_expr *matrix)
7847 {
7848 int row, matrix_rows, col, matrix_cols;
7849 gfc_expr *result;
7850
7851 if (!is_constant_array_expr (matrix))
7852 return NULL;
7853
7854 gcc_assert (matrix->rank == 2);
7855
7856 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
7857 &matrix->where);
7858 result->rank = 2;
7859 result->shape = gfc_get_shape (result->rank);
7860 mpz_set (result->shape[0], matrix->shape[1]);
7861 mpz_set (result->shape[1], matrix->shape[0]);
7862
7863 if (matrix->ts.type == BT_CHARACTER)
7864 result->ts.u.cl = matrix->ts.u.cl;
7865 else if (matrix->ts.type == BT_DERIVED)
7866 result->ts.u.derived = matrix->ts.u.derived;
7867
7868 matrix_rows = mpz_get_si (matrix->shape[0]);
7869 matrix_cols = mpz_get_si (matrix->shape[1]);
7870 for (row = 0; row < matrix_rows; ++row)
7871 for (col = 0; col < matrix_cols; ++col)
7872 {
7873 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
7874 col * matrix_rows + row);
7875 gfc_constructor_insert_expr (&result->value.constructor,
7876 gfc_copy_expr (e), &matrix->where,
7877 row * matrix_cols + col);
7878 }
7879
7880 return result;
7881 }
7882
7883
7884 gfc_expr *
7885 gfc_simplify_trim (gfc_expr *e)
7886 {
7887 gfc_expr *result;
7888 int count, i, len, lentrim;
7889
7890 if (e->expr_type != EXPR_CONSTANT)
7891 return NULL;
7892
7893 len = e->value.character.length;
7894 for (count = 0, i = 1; i <= len; ++i)
7895 {
7896 if (e->value.character.string[len - i] == ' ')
7897 count++;
7898 else
7899 break;
7900 }
7901
7902 lentrim = len - count;
7903
7904 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
7905 for (i = 0; i < lentrim; i++)
7906 result->value.character.string[i] = e->value.character.string[i];
7907
7908 return result;
7909 }
7910
7911
7912 gfc_expr *
7913 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
7914 {
7915 gfc_expr *result;
7916 gfc_ref *ref;
7917 gfc_array_spec *as;
7918 gfc_constructor *sub_cons;
7919 bool first_image;
7920 int d;
7921
7922 if (!is_constant_array_expr (sub))
7923 return NULL;
7924
7925 /* Follow any component references. */
7926 as = coarray->symtree->n.sym->as;
7927 for (ref = coarray->ref; ref; ref = ref->next)
7928 if (ref->type == REF_COMPONENT)
7929 as = ref->u.ar.as;
7930
7931 if (as->type == AS_DEFERRED)
7932 return NULL;
7933
7934 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
7935 the cosubscript addresses the first image. */
7936
7937 sub_cons = gfc_constructor_first (sub->value.constructor);
7938 first_image = true;
7939
7940 for (d = 1; d <= as->corank; d++)
7941 {
7942 gfc_expr *ca_bound;
7943 int cmp;
7944
7945 gcc_assert (sub_cons != NULL);
7946
7947 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
7948 NULL, true);
7949 if (ca_bound == NULL)
7950 return NULL;
7951
7952 if (ca_bound == &gfc_bad_expr)
7953 return ca_bound;
7954
7955 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
7956
7957 if (cmp == 0)
7958 {
7959 gfc_free_expr (ca_bound);
7960 sub_cons = gfc_constructor_next (sub_cons);
7961 continue;
7962 }
7963
7964 first_image = false;
7965
7966 if (cmp > 0)
7967 {
7968 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
7969 "SUB has %ld and COARRAY lower bound is %ld)",
7970 &coarray->where, d,
7971 mpz_get_si (sub_cons->expr->value.integer),
7972 mpz_get_si (ca_bound->value.integer));
7973 gfc_free_expr (ca_bound);
7974 return &gfc_bad_expr;
7975 }
7976
7977 gfc_free_expr (ca_bound);
7978
7979 /* Check whether upperbound is valid for the multi-images case. */
7980 if (d < as->corank)
7981 {
7982 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
7983 NULL, true);
7984 if (ca_bound == &gfc_bad_expr)
7985 return ca_bound;
7986
7987 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
7988 && mpz_cmp (ca_bound->value.integer,
7989 sub_cons->expr->value.integer) < 0)
7990 {
7991 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
7992 "SUB has %ld and COARRAY upper bound is %ld)",
7993 &coarray->where, d,
7994 mpz_get_si (sub_cons->expr->value.integer),
7995 mpz_get_si (ca_bound->value.integer));
7996 gfc_free_expr (ca_bound);
7997 return &gfc_bad_expr;
7998 }
7999
8000 if (ca_bound)
8001 gfc_free_expr (ca_bound);
8002 }
8003
8004 sub_cons = gfc_constructor_next (sub_cons);
8005 }
8006
8007 gcc_assert (sub_cons == NULL);
8008
8009 if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image)
8010 return NULL;
8011
8012 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
8013 &gfc_current_locus);
8014 if (first_image)
8015 mpz_set_si (result->value.integer, 1);
8016 else
8017 mpz_set_si (result->value.integer, 0);
8018
8019 return result;
8020 }
8021
8022 gfc_expr *
8023 gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED)
8024 {
8025 if (flag_coarray == GFC_FCOARRAY_NONE)
8026 {
8027 gfc_current_locus = *gfc_current_intrinsic_where;
8028 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
8029 return &gfc_bad_expr;
8030 }
8031
8032 /* Simplification is possible for fcoarray = single only. For all other modes
8033 the result depends on runtime conditions. */
8034 if (flag_coarray != GFC_FCOARRAY_SINGLE)
8035 return NULL;
8036
8037 if (gfc_is_constant_expr (image))
8038 {
8039 gfc_expr *result;
8040 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
8041 &image->where);
8042 if (mpz_get_si (image->value.integer) == 1)
8043 mpz_set_si (result->value.integer, 0);
8044 else
8045 mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE);
8046 return result;
8047 }
8048 else
8049 return NULL;
8050 }
8051
8052
8053 gfc_expr *
8054 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
8055 gfc_expr *distance ATTRIBUTE_UNUSED)
8056 {
8057 if (flag_coarray != GFC_FCOARRAY_SINGLE)
8058 return NULL;
8059
8060 /* If no coarray argument has been passed or when the first argument
8061 is actually a distance argment. */
8062 if (coarray == NULL || !gfc_is_coarray (coarray))
8063 {
8064 gfc_expr *result;
8065 /* FIXME: gfc_current_locus is wrong. */
8066 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
8067 &gfc_current_locus);
8068 mpz_set_si (result->value.integer, 1);
8069 return result;
8070 }
8071
8072 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
8073 return simplify_cobound (coarray, dim, NULL, 0);
8074 }
8075
8076
8077 gfc_expr *
8078 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
8079 {
8080 return simplify_bound (array, dim, kind, 1);
8081 }
8082
8083 gfc_expr *
8084 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
8085 {
8086 return simplify_cobound (array, dim, kind, 1);
8087 }
8088
8089
8090 gfc_expr *
8091 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
8092 {
8093 gfc_expr *result, *e;
8094 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
8095
8096 if (!is_constant_array_expr (vector)
8097 || !is_constant_array_expr (mask)
8098 || (!gfc_is_constant_expr (field)
8099 && !is_constant_array_expr (field)))
8100 return NULL;
8101
8102 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
8103 &vector->where);
8104 if (vector->ts.type == BT_DERIVED)
8105 result->ts.u.derived = vector->ts.u.derived;
8106 result->rank = mask->rank;
8107 result->shape = gfc_copy_shape (mask->shape, mask->rank);
8108
8109 if (vector->ts.type == BT_CHARACTER)
8110 result->ts.u.cl = vector->ts.u.cl;
8111
8112 vector_ctor = gfc_constructor_first (vector->value.constructor);
8113 mask_ctor = gfc_constructor_first (mask->value.constructor);
8114 field_ctor
8115 = field->expr_type == EXPR_ARRAY
8116 ? gfc_constructor_first (field->value.constructor)
8117 : NULL;
8118
8119 while (mask_ctor)
8120 {
8121 if (mask_ctor->expr->value.logical)
8122 {
8123 gcc_assert (vector_ctor);
8124 e = gfc_copy_expr (vector_ctor->expr);
8125 vector_ctor = gfc_constructor_next (vector_ctor);
8126 }
8127 else if (field->expr_type == EXPR_ARRAY)
8128 e = gfc_copy_expr (field_ctor->expr);
8129 else
8130 e = gfc_copy_expr (field);
8131
8132 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
8133
8134 mask_ctor = gfc_constructor_next (mask_ctor);
8135 field_ctor = gfc_constructor_next (field_ctor);
8136 }
8137
8138 return result;
8139 }
8140
8141
8142 gfc_expr *
8143 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
8144 {
8145 gfc_expr *result;
8146 int back;
8147 size_t index, len, lenset;
8148 size_t i;
8149 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
8150
8151 if (k == -1)
8152 return &gfc_bad_expr;
8153
8154 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
8155 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
8156 return NULL;
8157
8158 if (b != NULL && b->value.logical != 0)
8159 back = 1;
8160 else
8161 back = 0;
8162
8163 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
8164
8165 len = s->value.character.length;
8166 lenset = set->value.character.length;
8167
8168 if (len == 0)
8169 {
8170 mpz_set_ui (result->value.integer, 0);
8171 return result;
8172 }
8173
8174 if (back == 0)
8175 {
8176 if (lenset == 0)
8177 {
8178 mpz_set_ui (result->value.integer, 1);
8179 return result;
8180 }
8181
8182 index = wide_strspn (s->value.character.string,
8183 set->value.character.string) + 1;
8184 if (index > len)
8185 index = 0;
8186
8187 }
8188 else
8189 {
8190 if (lenset == 0)
8191 {
8192 mpz_set_ui (result->value.integer, len);
8193 return result;
8194 }
8195 for (index = len; index > 0; index --)
8196 {
8197 for (i = 0; i < lenset; i++)
8198 {
8199 if (s->value.character.string[index - 1]
8200 == set->value.character.string[i])
8201 break;
8202 }
8203 if (i == lenset)
8204 break;
8205 }
8206 }
8207
8208 mpz_set_ui (result->value.integer, index);
8209 return result;
8210 }
8211
8212
8213 gfc_expr *
8214 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
8215 {
8216 gfc_expr *result;
8217 int kind;
8218
8219 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
8220 return NULL;
8221
8222 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
8223
8224 switch (x->ts.type)
8225 {
8226 case BT_INTEGER:
8227 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
8228 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
8229 return range_check (result, "XOR");
8230
8231 case BT_LOGICAL:
8232 return gfc_get_logical_expr (kind, &x->where,
8233 (x->value.logical && !y->value.logical)
8234 || (!x->value.logical && y->value.logical));
8235
8236 default:
8237 gcc_unreachable ();
8238 }
8239 }
8240
8241
8242 /****************** Constant simplification *****************/
8243
8244 /* Master function to convert one constant to another. While this is
8245 used as a simplification function, it requires the destination type
8246 and kind information which is supplied by a special case in
8247 do_simplify(). */
8248
8249 gfc_expr *
8250 gfc_convert_constant (gfc_expr *e, bt type, int kind)
8251 {
8252 gfc_expr *result, *(*f) (gfc_expr *, int);
8253 gfc_constructor *c, *t;
8254
8255 switch (e->ts.type)
8256 {
8257 case BT_INTEGER:
8258 switch (type)
8259 {
8260 case BT_INTEGER:
8261 f = gfc_int2int;
8262 break;
8263 case BT_REAL:
8264 f = gfc_int2real;
8265 break;
8266 case BT_COMPLEX:
8267 f = gfc_int2complex;
8268 break;
8269 case BT_LOGICAL:
8270 f = gfc_int2log;
8271 break;
8272 default:
8273 goto oops;
8274 }
8275 break;
8276
8277 case BT_REAL:
8278 switch (type)
8279 {
8280 case BT_INTEGER:
8281 f = gfc_real2int;
8282 break;
8283 case BT_REAL:
8284 f = gfc_real2real;
8285 break;
8286 case BT_COMPLEX:
8287 f = gfc_real2complex;
8288 break;
8289 default:
8290 goto oops;
8291 }
8292 break;
8293
8294 case BT_COMPLEX:
8295 switch (type)
8296 {
8297 case BT_INTEGER:
8298 f = gfc_complex2int;
8299 break;
8300 case BT_REAL:
8301 f = gfc_complex2real;
8302 break;
8303 case BT_COMPLEX:
8304 f = gfc_complex2complex;
8305 break;
8306
8307 default:
8308 goto oops;
8309 }
8310 break;
8311
8312 case BT_LOGICAL:
8313 switch (type)
8314 {
8315 case BT_INTEGER:
8316 f = gfc_log2int;
8317 break;
8318 case BT_LOGICAL:
8319 f = gfc_log2log;
8320 break;
8321 default:
8322 goto oops;
8323 }
8324 break;
8325
8326 case BT_HOLLERITH:
8327 switch (type)
8328 {
8329 case BT_INTEGER:
8330 f = gfc_hollerith2int;
8331 break;
8332
8333 case BT_REAL:
8334 f = gfc_hollerith2real;
8335 break;
8336
8337 case BT_COMPLEX:
8338 f = gfc_hollerith2complex;
8339 break;
8340
8341 case BT_CHARACTER:
8342 f = gfc_hollerith2character;
8343 break;
8344
8345 case BT_LOGICAL:
8346 f = gfc_hollerith2logical;
8347 break;
8348
8349 default:
8350 goto oops;
8351 }
8352 break;
8353
8354 case BT_CHARACTER:
8355 if (type == BT_CHARACTER)
8356 f = gfc_character2character;
8357 else
8358 goto oops;
8359 break;
8360
8361 default:
8362 oops:
8363 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
8364 }
8365
8366 result = NULL;
8367
8368 switch (e->expr_type)
8369 {
8370 case EXPR_CONSTANT:
8371 result = f (e, kind);
8372 if (result == NULL)
8373 return &gfc_bad_expr;
8374 break;
8375
8376 case EXPR_ARRAY:
8377 if (!gfc_is_constant_expr (e))
8378 break;
8379
8380 result = gfc_get_array_expr (type, kind, &e->where);
8381 result->shape = gfc_copy_shape (e->shape, e->rank);
8382 result->rank = e->rank;
8383
8384 for (c = gfc_constructor_first (e->value.constructor);
8385 c; c = gfc_constructor_next (c))
8386 {
8387 gfc_expr *tmp;
8388 if (c->iterator == NULL)
8389 {
8390 if (c->expr->expr_type == EXPR_ARRAY)
8391 tmp = gfc_convert_constant (c->expr, type, kind);
8392 else
8393 tmp = f (c->expr, kind);
8394 }
8395 else
8396 tmp = gfc_convert_constant (c->expr, type, kind);
8397
8398 if (tmp == NULL || tmp == &gfc_bad_expr)
8399 {
8400 gfc_free_expr (result);
8401 return NULL;
8402 }
8403
8404 t = gfc_constructor_append_expr (&result->value.constructor,
8405 tmp, &c->where);
8406 if (c->iterator)
8407 t->iterator = gfc_copy_iterator (c->iterator);
8408 }
8409
8410 break;
8411
8412 default:
8413 break;
8414 }
8415
8416 return result;
8417 }
8418
8419
8420 /* Function for converting character constants. */
8421 gfc_expr *
8422 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
8423 {
8424 gfc_expr *result;
8425 int i;
8426
8427 if (!gfc_is_constant_expr (e))
8428 return NULL;
8429
8430 if (e->expr_type == EXPR_CONSTANT)
8431 {
8432 /* Simple case of a scalar. */
8433 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
8434 if (result == NULL)
8435 return &gfc_bad_expr;
8436
8437 result->value.character.length = e->value.character.length;
8438 result->value.character.string
8439 = gfc_get_wide_string (e->value.character.length + 1);
8440 memcpy (result->value.character.string, e->value.character.string,
8441 (e->value.character.length + 1) * sizeof (gfc_char_t));
8442
8443 /* Check we only have values representable in the destination kind. */
8444 for (i = 0; i < result->value.character.length; i++)
8445 if (!gfc_check_character_range (result->value.character.string[i],
8446 kind))
8447 {
8448 gfc_error ("Character %qs in string at %L cannot be converted "
8449 "into character kind %d",
8450 gfc_print_wide_char (result->value.character.string[i]),
8451 &e->where, kind);
8452 gfc_free_expr (result);
8453 return &gfc_bad_expr;
8454 }
8455
8456 return result;
8457 }
8458 else if (e->expr_type == EXPR_ARRAY)
8459 {
8460 /* For an array constructor, we convert each constructor element. */
8461 gfc_constructor *c;
8462
8463 result = gfc_get_array_expr (type, kind, &e->where);
8464 result->shape = gfc_copy_shape (e->shape, e->rank);
8465 result->rank = e->rank;
8466 result->ts.u.cl = e->ts.u.cl;
8467
8468 for (c = gfc_constructor_first (e->value.constructor);
8469 c; c = gfc_constructor_next (c))
8470 {
8471 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
8472 if (tmp == &gfc_bad_expr)
8473 {
8474 gfc_free_expr (result);
8475 return &gfc_bad_expr;
8476 }
8477
8478 if (tmp == NULL)
8479 {
8480 gfc_free_expr (result);
8481 return NULL;
8482 }
8483
8484 gfc_constructor_append_expr (&result->value.constructor,
8485 tmp, &c->where);
8486 }
8487
8488 return result;
8489 }
8490 else
8491 return NULL;
8492 }
8493
8494
8495 gfc_expr *
8496 gfc_simplify_compiler_options (void)
8497 {
8498 char *str;
8499 gfc_expr *result;
8500
8501 str = gfc_get_option_string ();
8502 result = gfc_get_character_expr (gfc_default_character_kind,
8503 &gfc_current_locus, str, strlen (str));
8504 free (str);
8505 return result;
8506 }
8507
8508
8509 gfc_expr *
8510 gfc_simplify_compiler_version (void)
8511 {
8512 char *buffer;
8513 size_t len;
8514
8515 len = strlen ("GCC version ") + strlen (version_string);
8516 buffer = XALLOCAVEC (char, len + 1);
8517 snprintf (buffer, len + 1, "GCC version %s", version_string);
8518 return gfc_get_character_expr (gfc_default_character_kind,
8519 &gfc_current_locus, buffer, len);
8520 }
8521
8522 /* Simplification routines for intrinsics of IEEE modules. */
8523
8524 gfc_expr *
8525 simplify_ieee_selected_real_kind (gfc_expr *expr)
8526 {
8527 gfc_actual_arglist *arg;
8528 gfc_expr *p = NULL, *q = NULL, *rdx = NULL;
8529
8530 arg = expr->value.function.actual;
8531 p = arg->expr;
8532 if (arg->next)
8533 {
8534 q = arg->next->expr;
8535 if (arg->next->next)
8536 rdx = arg->next->next->expr;
8537 }
8538
8539 /* Currently, if IEEE is supported and this module is built, it means
8540 all our floating-point types conform to IEEE. Hence, we simply handle
8541 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
8542 return gfc_simplify_selected_real_kind (p, q, rdx);
8543 }
8544
8545 gfc_expr *
8546 simplify_ieee_support (gfc_expr *expr)
8547 {
8548 /* We consider that if the IEEE modules are loaded, we have full support
8549 for flags, halting and rounding, which are the three functions
8550 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
8551 expressions. One day, we will need libgfortran to detect support and
8552 communicate it back to us, allowing for partial support. */
8553
8554 return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where,
8555 true);
8556 }
8557
8558 bool
8559 matches_ieee_function_name (gfc_symbol *sym, const char *name)
8560 {
8561 int n = strlen(name);
8562
8563 if (!strncmp(sym->name, name, n))
8564 return true;
8565
8566 /* If a generic was used and renamed, we need more work to find out.
8567 Compare the specific name. */
8568 if (sym->generic && !strncmp(sym->generic->sym->name, name, n))
8569 return true;
8570
8571 return false;
8572 }
8573
8574 gfc_expr *
8575 gfc_simplify_ieee_functions (gfc_expr *expr)
8576 {
8577 gfc_symbol* sym = expr->symtree->n.sym;
8578
8579 if (matches_ieee_function_name(sym, "ieee_selected_real_kind"))
8580 return simplify_ieee_selected_real_kind (expr);
8581 else if (matches_ieee_function_name(sym, "ieee_support_flag")
8582 || matches_ieee_function_name(sym, "ieee_support_halting")
8583 || matches_ieee_function_name(sym, "ieee_support_rounding"))
8584 return simplify_ieee_support (expr);
8585 else
8586 return NULL;
8587 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org