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