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