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