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