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