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