?  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
blobbf60f7475d61fa3c2752244f96f0161fced44efa
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_d (x, x, 180.0, 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_fmod_d (tmp, x, 360.0, rnd_mode);
1776
1777 /* Set x = x * pi. */
1778 mpfr_const_pi (tmp, rnd_mode);
1779 mpfr_mul (x, x, tmp, rnd_mode);
1780
1781 /* Set x = x / 180. */
1782 mpfr_div_d (x, x, 180.0, rnd_mode);
1783
1784 mpfr_clear (tmp);
1785 }
1786
1787
1788 /* Convert argument to radians before calling a trig function. */
1789
1790 gfc_expr *
1791 gfc_simplify_trigd (gfc_expr *icall)
1792 {
1793 gfc_expr *arg;
1794
1795 arg = icall->value.function.actual->expr;
1796
1797 if (arg->ts.type != BT_REAL)
1798 gfc_internal_error ("in gfc_simplify_trigd(): Bad type");
1799
1800 if (arg->expr_type == EXPR_CONSTANT)
1801 /* Convert constant to radians before passing off to simplifier. */
1802 radians_f (arg->value.real, GFC_RND_MODE);
1803
1804 /* Let the usual simplifier take over - we just simplified the arg. */
1805 return simplify_trig_call (icall);
1806 }
1807
1808 /* Convert result of an inverse trig function to degrees. */
1809
1810 gfc_expr *
1811 gfc_simplify_atrigd (gfc_expr *icall)
1812 {
1813 gfc_expr *result;
1814
1815 if (icall->value.function.actual->expr->ts.type != BT_REAL)
1816 gfc_internal_error ("in gfc_simplify_atrigd(): Bad type");
1817
1818 /* See if another simplifier has work to do first. */
1819 result = simplify_trig_call (icall);
1820
1821 if (result && result->expr_type == EXPR_CONSTANT)
1822 {
1823 /* Convert constant to degrees after passing off to actual simplifier. */
1824 degrees_f (result->value.real, GFC_RND_MODE);
1825 return result;
1826 }
1827
1828 /* Let gfc_resolve_atrigd take care of the non-constant case. */
1829 return NULL;
1830 }
1831
1832 /* Convert the result of atan2 to degrees. */
1833
1834 gfc_expr *
1835 gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
1836 {
1837 gfc_expr *result;
1838
1839 if (x->ts.type != BT_REAL || y->ts.type != BT_REAL)
1840 gfc_internal_error ("in gfc_simplify_atan2d(): Bad type");
1841
1842 if (x->expr_type == EXPR_CONSTANT && y->expr_type == EXPR_CONSTANT)
1843 {
1844 result = gfc_simplify_atan2 (y, x);
1845 if (result != NULL)
1846 {
1847 degrees_f (result->value.real, GFC_RND_MODE);
1848 return result;
1849 }
1850 }
1851
1852 /* Let gfc_resolve_atan2d take care of the non-constant case. */
1853 return NULL;
1854 }
1855
1856 gfc_expr *
1857 gfc_simplify_cos (gfc_expr *x)
1858 {
1859 gfc_expr *result;
1860
1861 if (x->expr_type != EXPR_CONSTANT)
1862 return NULL;
1863
1864 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1865
1866 switch (x->ts.type)
1867 {
1868 case BT_REAL:
1869 mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
1870 break;
1871
1872 case BT_COMPLEX:
1873 gfc_set_model_kind (x->ts.kind);
1874 mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1875 break;
1876
1877 default:
1878 gfc_internal_error ("in gfc_simplify_cos(): Bad type");
1879 }
1880
1881 return range_check (result, "COS");
1882 }
1883
1884
1885 gfc_expr *
1886 gfc_simplify_cosh (gfc_expr *x)
1887 {
1888 gfc_expr *result;
1889
1890 if (x->expr_type != EXPR_CONSTANT)
1891 return NULL;
1892
1893 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
1894
1895 switch (x->ts.type)
1896 {
1897 case BT_REAL:
1898 mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
1899 break;
1900
1901 case BT_COMPLEX:
1902 mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
1903 break;
1904
1905 default:
1906 gcc_unreachable ();
1907 }
1908
1909 return range_check (result, "COSH");
1910 }
1911
1912
1913 gfc_expr *
1914 gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
1915 {
1916 gfc_expr *result;
1917
1918 if (!is_constant_array_expr (mask)
1919 || !gfc_is_constant_expr (dim)
1920 || !gfc_is_constant_expr (kind))
1921 return NULL;
1922
1923 result = transformational_result (mask, dim,
1924 BT_INTEGER,
1925 get_kind (BT_INTEGER, kind, "COUNT",
1926 gfc_default_integer_kind),
1927 &mask->where);
1928
1929 init_result_expr (result, 0, NULL);
1930
1931 /* Passing MASK twice, once as data array, once as mask.
1932 Whenever gfc_count is called, '1' is added to the result. */
1933 return !dim || mask->rank == 1 ?
1934 simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
1935 simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
1936 }
1937
1938
1939 gfc_expr *
1940 gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
1941 {
1942 gfc_expr *a, *result;
1943 int dm;
1944
1945 /* DIM is only useful for rank > 1, but deal with it here as one can
1946 set DIM = 1 for rank = 1. */
1947 if (dim)
1948 {
1949 if (!gfc_is_constant_expr (dim))
1950 return NULL;
1951 dm = mpz_get_si (dim->value.integer);
1952 }
1953 else
1954 dm = 1;
1955
1956 /* Copy array into 'a', simplify it, and then test for a constant array. */
1957 a = gfc_copy_expr (array);
1958 gfc_simplify_expr (a, 0);
1959 if (!is_constant_array_expr (a))
1960 {
1961 gfc_free_expr (a);
1962 return NULL;
1963 }
1964
1965 if (a->rank == 1)
1966 {
1967 gfc_constructor *ca, *cr;
1968 mpz_t size;
1969 int i, j, shft, sz;
1970
1971 if (!gfc_is_constant_expr (shift))
1972 {
1973 gfc_free_expr (a);
1974 return NULL;
1975 }
1976
1977 shft = mpz_get_si (shift->value.integer);
1978
1979 /* Case (i): If ARRAY has rank one, element i of the result is
1980 ARRAY (1 + MODULO (i + SHIFT - 1, SIZE (ARRAY))). */
1981
1982 mpz_init (size);
1983 gfc_array_size (a, &size);
1984 sz = mpz_get_si (size);
1985 mpz_clear (size);
1986
1987 /* Adjust shft to deal with right or left shifts. */
1988 shft = shft < 0 ? 1 - shft : shft;
1989
1990 /* Special case: Shift to the original order! */
1991 if (shft % sz == 0)
1992 return a;
1993
1994 result = gfc_copy_expr (a);
1995 cr = gfc_constructor_first (result->value.constructor);
1996 for (i = 0; i < sz; i++, cr = gfc_constructor_next (cr))
1997 {
1998 j = (i + shft) % sz;
1999 ca = gfc_constructor_first (a->value.constructor);
2000 while (j-- > 0)
2001 ca = gfc_constructor_next (ca);
2002 cr->expr = gfc_copy_expr (ca->expr);
2003 }
2004
2005 gfc_free_expr (a);
2006 return result;
2007 }
2008 else
2009 {
2010 /* FIXME: Deal with rank > 1 arrays. For now, don't leak memory. */
2011
2012 /* GCC bootstrap is too stupid to realize that the above code for dm
2013 is correct. First, dim can be specified for a rank 1 array. It is
2014 not needed in this nor used here. Second, the code is simply waiting
2015 for someone to implement rank > 1 simplification. For now, add a
2016 pessimization to the code that has a zero valid reason to be here. */
2017 if (dm > array->rank)
2018 gcc_unreachable ();
2019
2020 gfc_free_expr (a);
2021 }
2022
2023 return NULL;
2024 }
2025
2026
2027 gfc_expr *
2028 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
2029 {
2030 return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
2031 }
2032
2033
2034 gfc_expr *
2035 gfc_simplify_dble (gfc_expr *e)
2036 {
2037 gfc_expr *result = NULL;
2038
2039 if (e->expr_type != EXPR_CONSTANT)
2040 return NULL;
2041
2042 if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
2043 return &gfc_bad_expr;
2044
2045 result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
2046 if (result == &gfc_bad_expr)
2047 return &gfc_bad_expr;
2048
2049 return range_check (result, "DBLE");
2050 }
2051
2052
2053 gfc_expr *
2054 gfc_simplify_digits (gfc_expr *x)
2055 {
2056 int i, digits;
2057
2058 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2059
2060 switch (x->ts.type)
2061 {
2062 case BT_INTEGER:
2063 digits = gfc_integer_kinds[i].digits;
2064 break;
2065
2066 case BT_REAL:
2067 case BT_COMPLEX:
2068 digits = gfc_real_kinds[i].digits;
2069 break;
2070
2071 default:
2072 gcc_unreachable ();
2073 }
2074
2075 return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
2076 }
2077
2078
2079 gfc_expr *
2080 gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
2081 {
2082 gfc_expr *result;
2083 int kind;
2084
2085 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2086 return NULL;
2087
2088 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
2089 result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
2090
2091 switch (x->ts.type)
2092 {
2093 case BT_INTEGER:
2094 if (mpz_cmp (x->value.integer, y->value.integer) > 0)
2095 mpz_sub (result->value.integer, x->value.integer, y->value.integer);
2096 else
2097 mpz_set_ui (result->value.integer, 0);
2098
2099 break;
2100
2101 case BT_REAL:
2102 if (mpfr_cmp (x->value.real, y->value.real) > 0)
2103 mpfr_sub (result->value.real, x->value.real, y->value.real,
2104 GFC_RND_MODE);
2105 else
2106 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
2107
2108 break;
2109
2110 default:
2111 gfc_internal_error ("gfc_simplify_dim(): Bad type");
2112 }
2113
2114 return range_check (result, "DIM");
2115 }
2116
2117
2118 gfc_expr*
2119 gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
2120 {
2121
2122 gfc_expr temp;
2123
2124 if (!is_constant_array_expr (vector_a)
2125 || !is_constant_array_expr (vector_b))
2126 return NULL;
2127
2128 gcc_assert (vector_a->rank == 1);
2129 gcc_assert (vector_b->rank == 1);
2130
2131 temp.expr_type = EXPR_OP;
2132 gfc_clear_ts (&temp.ts);
2133 temp.value.op.op = INTRINSIC_NONE;
2134 temp.value.op.op1 = vector_a;
2135 temp.value.op.op2 = vector_b;
2136 gfc_type_convert_binary (&temp, 1);
2137
2138 return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true);
2139 }
2140
2141
2142 gfc_expr *
2143 gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
2144 {
2145 gfc_expr *a1, *a2, *result;
2146
2147 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2148 return NULL;
2149
2150 a1 = gfc_real2real (x, gfc_default_double_kind);
2151 a2 = gfc_real2real (y, gfc_default_double_kind);
2152
2153 result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
2154 mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
2155
2156 gfc_free_expr (a2);
2157 gfc_free_expr (a1);
2158
2159 return range_check (result, "DPROD");
2160 }
2161
2162
2163 static gfc_expr *
2164 simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
2165 bool right)
2166 {
2167 gfc_expr *result;
2168 int i, k, size, shift;
2169
2170 if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
2171 || shiftarg->expr_type != EXPR_CONSTANT)
2172 return NULL;
2173
2174 k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
2175 size = gfc_integer_kinds[k].bit_size;
2176
2177 gfc_extract_int (shiftarg, &shift);
2178
2179 /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
2180 if (right)
2181 shift = size - shift;
2182
2183 result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
2184 mpz_set_ui (result->value.integer, 0);
2185
2186 for (i = 0; i < shift; i++)
2187 if (mpz_tstbit (arg2->value.integer, size - shift + i))
2188 mpz_setbit (result->value.integer, i);
2189
2190 for (i = 0; i < size - shift; i++)
2191 if (mpz_tstbit (arg1->value.integer, i))
2192 mpz_setbit (result->value.integer, shift + i);
2193
2194 /* Convert to a signed value. */
2195 gfc_convert_mpz_to_signed (result->value.integer, size);
2196
2197 return result;
2198 }
2199
2200
2201 gfc_expr *
2202 gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2203 {
2204 return simplify_dshift (arg1, arg2, shiftarg, true);
2205 }
2206
2207
2208 gfc_expr *
2209 gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2210 {
2211 return simplify_dshift (arg1, arg2, shiftarg, false);
2212 }
2213
2214
2215 gfc_expr *
2216 gfc_simplify_erf (gfc_expr *x)
2217 {
2218 gfc_expr *result;
2219
2220 if (x->expr_type != EXPR_CONSTANT)
2221 return NULL;
2222
2223 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2224 mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
2225
2226 return range_check (result, "ERF");
2227 }
2228
2229
2230 gfc_expr *
2231 gfc_simplify_erfc (gfc_expr *x)
2232 {
2233 gfc_expr *result;
2234
2235 if (x->expr_type != EXPR_CONSTANT)
2236 return NULL;
2237
2238 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2239 mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
2240
2241 return range_check (result, "ERFC");
2242 }
2243
2244
2245 /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
2246
2247 #define MAX_ITER 200
2248 #define ARG_LIMIT 12
2249
2250 /* Calculate ERFC_SCALED directly by its definition:
2251
2252 ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
2253
2254 using a large precision for intermediate results. This is used for all
2255 but large values of the argument. */
2256 static void
2257 fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
2258 {
2259 mp_prec_t prec;
2260 mpfr_t a, b;
2261
2262 prec = mpfr_get_default_prec ();
2263 mpfr_set_default_prec (10 * prec);
2264
2265 mpfr_init (a);
2266 mpfr_init (b);
2267
2268 mpfr_set (a, arg, GFC_RND_MODE);
2269 mpfr_sqr (b, a, GFC_RND_MODE);
2270 mpfr_exp (b, b, GFC_RND_MODE);
2271 mpfr_erfc (a, a, GFC_RND_MODE);
2272 mpfr_mul (a, a, b, GFC_RND_MODE);
2273
2274 mpfr_set (res, a, GFC_RND_MODE);
2275 mpfr_set_default_prec (prec);
2276
2277 mpfr_clear (a);
2278 mpfr_clear (b);
2279 }
2280
2281 /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
2282
2283 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
2284 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
2285 / (2 * x**2)**n)
2286
2287 This is used for large values of the argument. Intermediate calculations
2288 are performed with twice the precision. We don't do a fixed number of
2289 iterations of the sum, but stop when it has converged to the required
2290 precision. */
2291 static void
2292 asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
2293 {
2294 mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
2295 mpz_t num;
2296 mp_prec_t prec;
2297 unsigned i;
2298
2299 prec = mpfr_get_default_prec ();
2300 mpfr_set_default_prec (2 * prec);
2301
2302 mpfr_init (sum);
2303 mpfr_init (x);
2304 mpfr_init (u);
2305 mpfr_init (v);
2306 mpfr_init (w);
2307 mpz_init (num);
2308
2309 mpfr_init (oldsum);
2310 mpfr_init (sumtrunc);
2311 mpfr_set_prec (oldsum, prec);
2312 mpfr_set_prec (sumtrunc, prec);
2313
2314 mpfr_set (x, arg, GFC_RND_MODE);
2315 mpfr_set_ui (sum, 1, GFC_RND_MODE);
2316 mpz_set_ui (num, 1);
2317
2318 mpfr_set (u, x, GFC_RND_MODE);
2319 mpfr_sqr (u, u, GFC_RND_MODE);
2320 mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
2321 mpfr_pow_si (u, u, -1, GFC_RND_MODE);
2322
2323 for (i = 1; i < MAX_ITER; i++)
2324 {
2325 mpfr_set (oldsum, sum, GFC_RND_MODE);
2326
2327 mpz_mul_ui (num, num, 2 * i - 1);
2328 mpz_neg (num, num);
2329
2330 mpfr_set (w, u, GFC_RND_MODE);
2331 mpfr_pow_ui (w, w, i, GFC_RND_MODE);
2332
2333 mpfr_set_z (v, num, GFC_RND_MODE);
2334 mpfr_mul (v, v, w, GFC_RND_MODE);
2335
2336 mpfr_add (sum, sum, v, GFC_RND_MODE);
2337
2338 mpfr_set (sumtrunc, sum, GFC_RND_MODE);
2339 if (mpfr_cmp (sumtrunc, oldsum) == 0)
2340 break;
2341 }
2342
2343 /* We should have converged by now; otherwise, ARG_LIMIT is probably
2344 set too low. */
2345 gcc_assert (i < MAX_ITER);
2346
2347 /* Divide by x * sqrt(Pi). */
2348 mpfr_const_pi (u, GFC_RND_MODE);
2349 mpfr_sqrt (u, u, GFC_RND_MODE);
2350 mpfr_mul (u, u, x, GFC_RND_MODE);
2351 mpfr_div (sum, sum, u, GFC_RND_MODE);
2352
2353 mpfr_set (res, sum, GFC_RND_MODE);
2354 mpfr_set_default_prec (prec);
2355
2356 mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
2357 mpz_clear (num);
2358 }
2359
2360
2361 gfc_expr *
2362 gfc_simplify_erfc_scaled (gfc_expr *x)
2363 {
2364 gfc_expr *result;
2365
2366 if (x->expr_type != EXPR_CONSTANT)
2367 return NULL;
2368
2369 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2370 if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
2371 asympt_erfc_scaled (result->value.real, x->value.real);
2372 else
2373 fullprec_erfc_scaled (result->value.real, x->value.real);
2374
2375 return range_check (result, "ERFC_SCALED");
2376 }
2377
2378 #undef MAX_ITER
2379 #undef ARG_LIMIT
2380
2381
2382 gfc_expr *
2383 gfc_simplify_epsilon (gfc_expr *e)
2384 {
2385 gfc_expr *result;
2386 int i;
2387
2388 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2389
2390 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
2391 mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
2392
2393 return range_check (result, "EPSILON");
2394 }
2395
2396
2397 gfc_expr *
2398 gfc_simplify_exp (gfc_expr *x)
2399 {
2400 gfc_expr *result;
2401
2402 if (x->expr_type != EXPR_CONSTANT)
2403 return NULL;
2404
2405 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2406
2407 switch (x->ts.type)
2408 {
2409 case BT_REAL:
2410 mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
2411 break;
2412
2413 case BT_COMPLEX:
2414 gfc_set_model_kind (x->ts.kind);
2415 mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
2416 break;
2417
2418 default:
2419 gfc_internal_error ("in gfc_simplify_exp(): Bad type");
2420 }
2421
2422 return range_check (result, "EXP");
2423 }
2424
2425
2426 gfc_expr *
2427 gfc_simplify_exponent (gfc_expr *x)
2428 {
2429 long int val;
2430 gfc_expr *result;
2431
2432 if (x->expr_type != EXPR_CONSTANT)
2433 return NULL;
2434
2435 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
2436 &x->where);
2437
2438 /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
2439 if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real))
2440 {
2441 int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
2442 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
2443 return result;
2444 }
2445
2446 /* EXPONENT(+/- 0.0) = 0 */
2447 if (mpfr_zero_p (x->value.real))
2448 {
2449 mpz_set_ui (result->value.integer, 0);
2450 return result;
2451 }
2452
2453 gfc_set_model (x->value.real);
2454
2455 val = (long int) mpfr_get_exp (x->value.real);
2456 mpz_set_si (result->value.integer, val);
2457
2458 return range_check (result, "EXPONENT");
2459 }
2460
2461
2462 gfc_expr *
2463 gfc_simplify_float (gfc_expr *a)
2464 {
2465 gfc_expr *result;
2466
2467 if (a->expr_type != EXPR_CONSTANT)
2468 return NULL;
2469
2470 if (a->is_boz)
2471 {
2472 if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
2473 return &gfc_bad_expr;
2474
2475 result = gfc_copy_expr (a);
2476 }
2477 else
2478 result = gfc_int2real (a, gfc_default_real_kind);
2479
2480 return range_check (result, "FLOAT");
2481 }
2482
2483
2484 static bool
2485 is_last_ref_vtab (gfc_expr *e)
2486 {
2487 gfc_ref *ref;
2488 gfc_component *comp = NULL;
2489
2490 if (e->expr_type != EXPR_VARIABLE)
2491 return false;
2492
2493 for (ref = e->ref; ref; ref = ref->next)
2494 if (ref->type == REF_COMPONENT)
2495 comp = ref->u.c.component;
2496
2497 if (!e->ref || !comp)
2498 return e->symtree->n.sym->attr.vtab;
2499
2500 if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
2501 return true;
2502
2503 return false;
2504 }
2505
2506
2507 gfc_expr *
2508 gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
2509 {
2510 /* Avoid simplification of resolved symbols. */
2511 if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
2512 return NULL;
2513
2514 if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
2515 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
2516 gfc_type_is_extension_of (mold->ts.u.derived,
2517 a->ts.u.derived));
2518
2519 if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
2520 return NULL;
2521
2522 /* Return .false. if the dynamic type can never be the same. */
2523 if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
2524 && !gfc_type_is_extension_of
2525 (mold->ts.u.derived->components->ts.u.derived,
2526 a->ts.u.derived->components->ts.u.derived)
2527 && !gfc_type_is_extension_of
2528 (a->ts.u.derived->components->ts.u.derived,
2529 mold->ts.u.derived->components->ts.u.derived))
2530 || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
2531 && !gfc_type_is_extension_of
2532 (a->ts.u.derived,
2533 mold->ts.u.derived->components->ts.u.derived)
2534 && !gfc_type_is_extension_of
2535 (mold->ts.u.derived->components->ts.u.derived,
2536 a->ts.u.derived))
2537 || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
2538 && !gfc_type_is_extension_of
2539 (mold->ts.u.derived,
2540 a->ts.u.derived->components->ts.u.derived)))
2541 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
2542
2543 if (mold->ts.type == BT_DERIVED
2544 && gfc_type_is_extension_of (mold->ts.u.derived,
2545 a->ts.u.derived->components->ts.u.derived))
2546 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
2547
2548 return NULL;
2549 }
2550
2551
2552 gfc_expr *
2553 gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
2554 {
2555 /* Avoid simplification of resolved symbols. */
2556 if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
2557 return NULL;
2558
2559 /* Return .false. if the dynamic type can never be the
2560 same. */
2561 if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok)
2562 || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok))
2563 && !gfc_type_compatible (&a->ts, &b->ts)
2564 && !gfc_type_compatible (&b->ts, &a->ts))
2565 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
2566
2567 if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
2568 return NULL;
2569
2570 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
2571 gfc_compare_derived_types (a->ts.u.derived,
2572 b->ts.u.derived));
2573 }
2574
2575
2576 gfc_expr *
2577 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
2578 {
2579 gfc_expr *result;
2580 mpfr_t floor;
2581 int kind;
2582
2583 kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
2584 if (kind == -1)
2585 gfc_internal_error ("gfc_simplify_floor(): Bad kind");
2586
2587 if (e->expr_type != EXPR_CONSTANT)
2588 return NULL;
2589
2590 mpfr_init2 (floor, mpfr_get_prec (e->value.real));
2591 mpfr_floor (floor, e->value.real);
2592
2593 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
2594 gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
2595
2596 mpfr_clear (floor);
2597
2598 return range_check (result, "FLOOR");
2599 }
2600
2601
2602 gfc_expr *
2603 gfc_simplify_fraction (gfc_expr *x)
2604 {
2605 gfc_expr *result;
2606
2607 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2608 mpfr_t absv, exp, pow2;
2609 #else
2610 mpfr_exp_t e;
2611 #endif
2612
2613 if (x->expr_type != EXPR_CONSTANT)
2614 return NULL;
2615
2616 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
2617
2618 /* FRACTION(inf) = NaN. */
2619 if (mpfr_inf_p (x->value.real))
2620 {
2621 mpfr_set_nan (result->value.real);
2622 return result;
2623 }
2624
2625 #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0)
2626
2627 /* MPFR versions before 3.1.0 do not include mpfr_frexp.
2628 TODO: remove the kludge when MPFR 3.1.0 or newer will be required */
2629
2630 if (mpfr_sgn (x->value.real) == 0)
2631 {
2632 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
2633 return result;
2634 }
2635
2636 gfc_set_model_kind (x->ts.kind);
2637 mpfr_init (exp);
2638 mpfr_init (absv);
2639 mpfr_init (pow2);
2640
2641 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
2642 mpfr_log2 (exp, absv, GFC_RND_MODE);
2643
2644 mpfr_trunc (exp, exp);
2645 mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
2646
2647 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
2648
2649 mpfr_div (result->value.real, x->value.real, pow2, GFC_RND_MODE);
2650
2651 mpfr_clears (exp, absv, pow2, NULL);
2652
2653 #else
2654
2655 /* mpfr_frexp() correctly handles zeros and NaNs. */
2656 mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE);
2657
2658 #endif
2659
2660 return range_check (result, "FRACTION");
2661 }
2662
2663
2664 gfc_expr *
2665 gfc_simplify_gamma (gfc_expr *x)
2666 {
2667 gfc_expr *result;
2668
2669 if (x->expr_type != EXPR_CONSTANT)
2670 return NULL;
2671
2672 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2673 mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
2674
2675 return range_check (result, "GAMMA");
2676 }
2677
2678
2679 gfc_expr *
2680 gfc_simplify_huge (gfc_expr *e)
2681 {
2682 gfc_expr *result;
2683 int i;
2684
2685 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
2686 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
2687
2688 switch (e->ts.type)
2689 {
2690 case BT_INTEGER:
2691 mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
2692 break;
2693
2694 case BT_REAL:
2695 mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
2696 break;
2697
2698 default:
2699 gcc_unreachable ();
2700 }
2701
2702 return result;
2703 }
2704
2705
2706 gfc_expr *
2707 gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
2708 {
2709 gfc_expr *result;
2710
2711 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2712 return NULL;
2713
2714 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2715 mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
2716 return range_check (result, "HYPOT");
2717 }
2718
2719
2720 /* We use the processor's collating sequence, because all
2721 systems that gfortran currently works on are ASCII. */
2722
2723 gfc_expr *
2724 gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
2725 {
2726 gfc_expr *result;
2727 gfc_char_t index;
2728 int k;
2729
2730 if (e->expr_type != EXPR_CONSTANT)
2731 return NULL;
2732
2733 if (e->value.character.length != 1)
2734 {
2735 gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
2736 return &gfc_bad_expr;
2737 }
2738
2739 index = e->value.character.string[0];
2740
2741 if (warn_surprising && index > 127)
2742 gfc_warning (OPT_Wsurprising,
2743 "Argument of IACHAR function at %L outside of range 0..127",
2744 &e->where);
2745
2746 k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
2747 if (k == -1)
2748 return &gfc_bad_expr;
2749
2750 result = gfc_get_int_expr (k, &e->where, index);
2751
2752 return range_check (result, "IACHAR");
2753 }
2754
2755
2756 static gfc_expr *
2757 do_bit_and (gfc_expr *result, gfc_expr *e)
2758 {
2759 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
2760 gcc_assert (result->ts.type == BT_INTEGER
2761 && result->expr_type == EXPR_CONSTANT);
2762
2763 mpz_and (result->value.integer, result->value.integer, e->value.integer);
2764 return result;
2765 }
2766
2767
2768 gfc_expr *
2769 gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2770 {
2771 return simplify_transformation (array, dim, mask, -1, do_bit_and);
2772 }
2773
2774
2775 static gfc_expr *
2776 do_bit_ior (gfc_expr *result, gfc_expr *e)
2777 {
2778 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
2779 gcc_assert (result->ts.type == BT_INTEGER
2780 && result->expr_type == EXPR_CONSTANT);
2781
2782 mpz_ior (result->value.integer, result->value.integer, e->value.integer);
2783 return result;
2784 }
2785
2786
2787 gfc_expr *
2788 gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2789 {
2790 return simplify_transformation (array, dim, mask, 0, do_bit_ior);
2791 }
2792
2793
2794 gfc_expr *
2795 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
2796 {
2797 gfc_expr *result;
2798
2799 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2800 return NULL;
2801
2802 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2803 mpz_and (result->value.integer, x->value.integer, y->value.integer);
2804
2805 return range_check (result, "IAND");
2806 }
2807
2808
2809 gfc_expr *
2810 gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
2811 {
2812 gfc_expr *result;
2813 int k, pos;
2814
2815 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2816 return NULL;
2817
2818 gfc_extract_int (y, &pos);
2819
2820 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2821
2822 result = gfc_copy_expr (x);
2823
2824 convert_mpz_to_unsigned (result->value.integer,
2825 gfc_integer_kinds[k].bit_size);
2826
2827 mpz_clrbit (result->value.integer, pos);
2828
2829 gfc_convert_mpz_to_signed (result->value.integer,
2830 gfc_integer_kinds[k].bit_size);
2831
2832 return result;
2833 }
2834
2835
2836 gfc_expr *
2837 gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
2838 {
2839 gfc_expr *result;
2840 int pos, len;
2841 int i, k, bitsize;
2842 int *bits;
2843
2844 if (x->expr_type != EXPR_CONSTANT
2845 || y->expr_type != EXPR_CONSTANT
2846 || z->expr_type != EXPR_CONSTANT)
2847 return NULL;
2848
2849 gfc_extract_int (y, &pos);
2850 gfc_extract_int (z, &len);
2851
2852 k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
2853
2854 bitsize = gfc_integer_kinds[k].bit_size;
2855
2856 if (pos + len > bitsize)
2857 {
2858 gfc_error ("Sum of second and third arguments of IBITS exceeds "
2859 "bit size at %L", &y->where);
2860 return &gfc_bad_expr;
2861 }
2862
2863 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
2864 convert_mpz_to_unsigned (result->value.integer,
2865 gfc_integer_kinds[k].bit_size);
2866
2867 bits = XCNEWVEC (int, bitsize);
2868
2869 for (i = 0; i < bitsize; i++)
2870 bits[i] = 0;
2871
2872 for (i = 0; i < len; i++)
2873 bits[i] = mpz_tstbit (x->value.integer, i + pos);
2874
2875 for (i = 0; i < bitsize; i++)
2876 {
2877 if (bits[i] == 0)
2878 mpz_clrbit (result->value.integer, i);
2879 else if (bits[i] == 1)
2880 mpz_setbit (result->value.integer, i);
2881 else
2882 gfc_internal_error ("IBITS: Bad bit");
2883 }
2884
2885 free (bits);
2886
2887 gfc_convert_mpz_to_signed (result->value.integer,
2888 gfc_integer_kinds[k].bit_size);
2889
2890 return result;
2891 }
2892
2893
2894 gfc_expr *
2895 gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
2896 {
2897 gfc_expr *result;
2898 int k, pos;
2899
2900 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2901 return NULL;
2902
2903 gfc_extract_int (y, &pos);
2904
2905 k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
2906
2907 result = gfc_copy_expr (x);
2908
2909 convert_mpz_to_unsigned (result->value.integer,
2910 gfc_integer_kinds[k].bit_size);
2911
2912 mpz_setbit (result->value.integer, pos);
2913
2914 gfc_convert_mpz_to_signed (result->value.integer,
2915 gfc_integer_kinds[k].bit_size);
2916
2917 return result;
2918 }
2919
2920
2921 gfc_expr *
2922 gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
2923 {
2924 gfc_expr *result;
2925 gfc_char_t index;
2926 int k;
2927
2928 if (e->expr_type != EXPR_CONSTANT)
2929 return NULL;
2930
2931 if (e->value.character.length != 1)
2932 {
2933 gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
2934 return &gfc_bad_expr;
2935 }
2936
2937 index = e->value.character.string[0];
2938
2939 k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
2940 if (k == -1)
2941 return &gfc_bad_expr;
2942
2943 result = gfc_get_int_expr (k, &e->where, index);
2944
2945 return range_check (result, "ICHAR");
2946 }
2947
2948
2949 gfc_expr *
2950 gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
2951 {
2952 gfc_expr *result;
2953
2954 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
2955 return NULL;
2956
2957 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
2958 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
2959
2960 return range_check (result, "IEOR");
2961 }
2962
2963
2964 gfc_expr *
2965 gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
2966 {
2967 gfc_expr *result;
2968 int back, len, lensub;
2969 int i, j, k, count, index = 0, start;
2970
2971 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
2972 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
2973 return NULL;
2974
2975 if (b != NULL && b->value.logical != 0)
2976 back = 1;
2977 else
2978 back = 0;
2979
2980 k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
2981 if (k == -1)
2982 return &gfc_bad_expr;
2983
2984 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
2985
2986 len = x->value.character.length;
2987 lensub = y->value.character.length;
2988
2989 if (len < lensub)
2990 {
2991 mpz_set_si (result->value.integer, 0);
2992 return result;
2993 }
2994
2995 if (back == 0)
2996 {
2997 if (lensub == 0)
2998 {
2999 mpz_set_si (result->value.integer, 1);
3000 return result;
3001 }
3002 else if (lensub == 1)
3003 {
3004 for (i = 0; i < len; i++)
3005 {
3006 for (j = 0; j < lensub; j++)
3007 {
3008 if (y->value.character.string[j]
3009 == x->value.character.string[i])
3010 {
3011 index = i + 1;
3012 goto done;
3013 }
3014 }
3015 }
3016 }
3017 else
3018 {
3019 for (i = 0; i < len; i++)
3020 {
3021 for (j = 0; j < lensub; j++)
3022 {
3023 if (y->value.character.string[j]
3024 == x->value.character.string[i])
3025 {
3026 start = i;
3027 count = 0;
3028
3029 for (k = 0; k < lensub; k++)
3030 {
3031 if (y->value.character.string[k]
3032 == x->value.character.string[k + start])
3033 count++;
3034 }
3035
3036 if (count == lensub)
3037 {
3038 index = start + 1;
3039 goto done;
3040 }
3041 }
3042 }
3043 }
3044 }
3045
3046 }
3047 else
3048 {
3049 if (lensub == 0)
3050 {
3051 mpz_set_si (result->value.integer, len + 1);
3052 return result;
3053 }
3054 else if (lensub == 1)
3055 {
3056 for (i = 0; i < len; i++)
3057 {
3058 for (j = 0; j < lensub; j++)
3059 {
3060 if (y->value.character.string[j]
3061 == x->value.character.string[len - i])
3062 {
3063 index = len - i + 1;
3064 goto done;
3065 }
3066 }
3067 }
3068 }
3069 else
3070 {
3071 for (i = 0; i < len; i++)
3072 {
3073 for (j = 0; j < lensub; j++)
3074 {
3075 if (y->value.character.string[j]
3076 == x->value.character.string[len - i])
3077 {
3078 start = len - i;
3079 if (start <= len - lensub)
3080 {
3081 count = 0;
3082 for (k = 0; k < lensub; k++)
3083 if (y->value.character.string[k]
3084 == x->value.character.string[k + start])
3085 count++;
3086
3087 if (count == lensub)
3088 {
3089 index = start + 1;
3090 goto done;
3091 }
3092 }
3093 else
3094 {
3095 continue;
3096 }
3097 }
3098 }
3099 }
3100 }
3101 }
3102
3103 done:
3104 mpz_set_si (result->value.integer, index);
3105 return range_check (result, "INDEX");
3106 }
3107
3108
3109 static gfc_expr *
3110 simplify_intconv (gfc_expr *e, int kind, const char *name)
3111 {
3112 gfc_expr *result = NULL;
3113
3114 if (e->expr_type != EXPR_CONSTANT)
3115 return NULL;
3116
3117 result = gfc_convert_constant (e, BT_INTEGER, kind);
3118 if (result == &gfc_bad_expr)
3119 return &gfc_bad_expr;
3120
3121 return range_check (result, name);
3122 }
3123
3124
3125 gfc_expr *
3126 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
3127 {
3128 int kind;
3129
3130 kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
3131 if (kind == -1)
3132 return &gfc_bad_expr;
3133
3134 return simplify_intconv (e, kind, "INT");
3135 }
3136
3137 gfc_expr *
3138 gfc_simplify_int2 (gfc_expr *e)
3139 {
3140 return simplify_intconv (e, 2, "INT2");
3141 }
3142
3143
3144 gfc_expr *
3145 gfc_simplify_int8 (gfc_expr *e)
3146 {
3147 return simplify_intconv (e, 8, "INT8");
3148 }
3149
3150
3151 gfc_expr *
3152 gfc_simplify_long (gfc_expr *e)
3153 {
3154 return simplify_intconv (e, 4, "LONG");
3155 }
3156
3157
3158 gfc_expr *
3159 gfc_simplify_ifix (gfc_expr *e)
3160 {
3161 gfc_expr *rtrunc, *result;
3162
3163 if (e->expr_type != EXPR_CONSTANT)
3164 return NULL;
3165
3166 rtrunc = gfc_copy_expr (e);
3167 mpfr_trunc (rtrunc->value.real, e->value.real);
3168
3169 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3170 &e->where);
3171 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3172
3173 gfc_free_expr (rtrunc);
3174
3175 return range_check (result, "IFIX");
3176 }
3177
3178
3179 gfc_expr *
3180 gfc_simplify_idint (gfc_expr *e)
3181 {
3182 gfc_expr *rtrunc, *result;
3183
3184 if (e->expr_type != EXPR_CONSTANT)
3185 return NULL;
3186
3187 rtrunc = gfc_copy_expr (e);
3188 mpfr_trunc (rtrunc->value.real, e->value.real);
3189
3190 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
3191 &e->where);
3192 gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
3193
3194 gfc_free_expr (rtrunc);
3195
3196 return range_check (result, "IDINT");
3197 }
3198
3199
3200 gfc_expr *
3201 gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
3202 {
3203 gfc_expr *result;
3204
3205 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
3206 return NULL;
3207
3208 result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
3209 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
3210
3211 return range_check (result, "IOR");
3212 }
3213
3214
3215 static gfc_expr *
3216 do_bit_xor (gfc_expr *result, gfc_expr *e)
3217 {
3218 gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
3219 gcc_assert (result->ts.type == BT_INTEGER
3220 && result->expr_type == EXPR_CONSTANT);
3221
3222 mpz_xor (result->value.integer, result->value.integer, e->value.integer);
3223 return result;
3224 }
3225
3226
3227 gfc_expr *
3228 gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3229 {
3230 return simplify_transformation (array, dim, mask, 0, do_bit_xor);
3231 }
3232
3233
3234 gfc_expr *
3235 gfc_simplify_is_iostat_end (gfc_expr *x)
3236 {
3237 if (x->expr_type != EXPR_CONSTANT)
3238 return NULL;
3239
3240 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3241 mpz_cmp_si (x->value.integer,
3242 LIBERROR_END) == 0);
3243 }
3244
3245
3246 gfc_expr *
3247 gfc_simplify_is_iostat_eor (gfc_expr *x)
3248 {
3249 if (x->expr_type != EXPR_CONSTANT)
3250 return NULL;
3251
3252 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3253 mpz_cmp_si (x->value.integer,
3254 LIBERROR_EOR) == 0);
3255 }
3256
3257
3258 gfc_expr *
3259 gfc_simplify_isnan (gfc_expr *x)
3260 {
3261 if (x->expr_type != EXPR_CONSTANT)
3262 return NULL;
3263
3264 return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
3265 mpfr_nan_p (x->value.real));
3266 }
3267
3268
3269 /* Performs a shift on its first argument. Depending on the last
3270 argument, the shift can be arithmetic, i.e. with filling from the
3271 left like in the SHIFTA intrinsic. */
3272 static gfc_expr *
3273 simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
3274 bool arithmetic, int direction)
3275 {
3276 gfc_expr *result;
3277 int ashift, *bits, i, k, bitsize, shift;
3278
3279 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3280 return NULL;
3281
3282 gfc_extract_int (s, &shift);
3283
3284 k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
3285 bitsize = gfc_integer_kinds[k].bit_size;
3286
3287 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3288
3289 if (shift == 0)
3290 {
3291 mpz_set (result->value.integer, e->value.integer);
3292 return result;
3293 }
3294
3295 if (direction > 0 && shift < 0)
3296 {
3297 /* Left shift, as in SHIFTL. */
3298 gfc_error ("Second argument of %s is negative at %L", name, &e->where);
3299 return &gfc_bad_expr;
3300 }
3301 else if (direction < 0)
3302 {
3303 /* Right shift, as in SHIFTR or SHIFTA. */
3304 if (shift < 0)
3305 {
3306 gfc_error ("Second argument of %s is negative at %L",
3307 name, &e->where);
3308 return &gfc_bad_expr;
3309 }
3310
3311 shift = -shift;
3312 }
3313
3314 ashift = (shift >= 0 ? shift : -shift);
3315
3316 if (ashift > bitsize)
3317 {
3318 gfc_error ("Magnitude of second argument of %s exceeds bit size "
3319 "at %L", name, &e->where);
3320 return &gfc_bad_expr;
3321 }
3322
3323 bits = XCNEWVEC (int, bitsize);
3324
3325 for (i = 0; i < bitsize; i++)
3326 bits[i] = mpz_tstbit (e->value.integer, i);
3327
3328 if (shift > 0)
3329 {
3330 /* Left shift. */
3331 for (i = 0; i < shift; i++)
3332 mpz_clrbit (result->value.integer, i);
3333
3334 for (i = 0; i < bitsize - shift; i++)
3335 {
3336 if (bits[i] == 0)
3337 mpz_clrbit (result->value.integer, i + shift);
3338 else
3339 mpz_setbit (result->value.integer, i + shift);
3340 }
3341 }
3342 else
3343 {
3344 /* Right shift. */
3345 if (arithmetic && bits[bitsize - 1])
3346 for (i = bitsize - 1; i >= bitsize - ashift; i--)
3347 mpz_setbit (result->value.integer, i);
3348 else
3349 for (i = bitsize - 1; i >= bitsize - ashift; i--)
3350 mpz_clrbit (result->value.integer, i);
3351
3352 for (i = bitsize - 1; i >= ashift; i--)
3353 {
3354 if (bits[i] == 0)
3355 mpz_clrbit (result->value.integer, i - ashift);
3356 else
3357 mpz_setbit (result->value.integer, i - ashift);
3358 }
3359 }
3360
3361 gfc_convert_mpz_to_signed (result->value.integer, bitsize);
3362 free (bits);
3363
3364 return result;
3365 }
3366
3367
3368 gfc_expr *
3369 gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
3370 {
3371 return simplify_shift (e, s, "ISHFT", false, 0);
3372 }
3373
3374
3375 gfc_expr *
3376 gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
3377 {
3378 return simplify_shift (e, s, "LSHIFT", false, 1);
3379 }
3380
3381
3382 gfc_expr *
3383 gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
3384 {
3385 return simplify_shift (e, s, "RSHIFT", true, -1);
3386 }
3387
3388
3389 gfc_expr *
3390 gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
3391 {
3392 return simplify_shift (e, s, "SHIFTA", true, -1);
3393 }
3394
3395
3396 gfc_expr *
3397 gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
3398 {
3399 return simplify_shift (e, s, "SHIFTL", false, 1);
3400 }
3401
3402
3403 gfc_expr *
3404 gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
3405 {
3406 return simplify_shift (e, s, "SHIFTR", false, -1);
3407 }
3408
3409
3410 gfc_expr *
3411 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
3412 {
3413 gfc_expr *result;
3414 int shift, ashift, isize, ssize, delta, k;
3415 int i, *bits;
3416
3417 if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
3418 return NULL;
3419
3420 gfc_extract_int (s, &shift);
3421
3422 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3423 isize = gfc_integer_kinds[k].bit_size;
3424
3425 if (sz != NULL)
3426 {
3427 if (sz->expr_type != EXPR_CONSTANT)
3428 return NULL;
3429
3430 gfc_extract_int (sz, &ssize);
3431 }
3432 else
3433 ssize = isize;
3434
3435 if (shift >= 0)
3436 ashift = shift;
3437 else
3438 ashift = -shift;
3439
3440 if (ashift > ssize)
3441 {
3442 if (sz == NULL)
3443 gfc_error ("Magnitude of second argument of ISHFTC exceeds "
3444 "BIT_SIZE of first argument at %C");
3445 else
3446 gfc_error ("Absolute value of SHIFT shall be less than or equal "
3447 "to SIZE at %C");
3448 return &gfc_bad_expr;
3449 }
3450
3451 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
3452
3453 mpz_set (result->value.integer, e->value.integer);
3454
3455 if (shift == 0)
3456 return result;
3457
3458 convert_mpz_to_unsigned (result->value.integer, isize);
3459
3460 bits = XCNEWVEC (int, ssize);
3461
3462 for (i = 0; i < ssize; i++)
3463 bits[i] = mpz_tstbit (e->value.integer, i);
3464
3465 delta = ssize - ashift;
3466
3467 if (shift > 0)
3468 {
3469 for (i = 0; i < delta; i++)
3470 {
3471 if (bits[i] == 0)
3472 mpz_clrbit (result->value.integer, i + shift);
3473 else
3474 mpz_setbit (result->value.integer, i + shift);
3475 }
3476
3477 for (i = delta; i < ssize; i++)
3478 {
3479 if (bits[i] == 0)
3480 mpz_clrbit (result->value.integer, i - delta);
3481 else
3482 mpz_setbit (result->value.integer, i - delta);
3483 }
3484 }
3485 else
3486 {
3487 for (i = 0; i < ashift; i++)
3488 {
3489 if (bits[i] == 0)
3490 mpz_clrbit (result->value.integer, i + delta);
3491 else
3492 mpz_setbit (result->value.integer, i + delta);
3493 }
3494
3495 for (i = ashift; i < ssize; i++)
3496 {
3497 if (bits[i] == 0)
3498 mpz_clrbit (result->value.integer, i + shift);
3499 else
3500 mpz_setbit (result->value.integer, i + shift);
3501 }
3502 }
3503
3504 gfc_convert_mpz_to_signed (result->value.integer, isize);
3505
3506 free (bits);
3507 return result;
3508 }
3509
3510
3511 gfc_expr *
3512 gfc_simplify_kind (gfc_expr *e)
3513 {
3514 return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
3515 }
3516
3517
3518 static gfc_expr *
3519 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
3520 gfc_array_spec *as, gfc_ref *ref, bool coarray)
3521 {
3522 gfc_expr *l, *u, *result;
3523 int k;
3524
3525 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
3526 gfc_default_integer_kind);
3527 if (k == -1)
3528 return &gfc_bad_expr;
3529
3530 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
3531
3532 /* For non-variables, LBOUND(expr, DIM=n) = 1 and
3533 UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
3534 if (!coarray && array->expr_type != EXPR_VARIABLE)
3535 {
3536 if (upper)
3537 {
3538 gfc_expr* dim = result;
3539 mpz_set_si (dim->value.integer, d);
3540
3541 result = simplify_size (array, dim, k);
3542 gfc_free_expr (dim);
3543 if (!result)
3544 goto returnNull;
3545 }
3546 else
3547 mpz_set_si (result->value.integer, 1);
3548
3549 goto done;
3550 }
3551
3552 /* Otherwise, we have a variable expression. */
3553 gcc_assert (array->expr_type == EXPR_VARIABLE);
3554 gcc_assert (as);
3555
3556 if (!gfc_resolve_array_spec (as, 0))
3557 return NULL;
3558
3559 /* The last dimension of an assumed-size array is special. */
3560 if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
3561 || (coarray && d == as->rank + as->corank
3562 && (!upper || flag_coarray == GFC_FCOARRAY_SINGLE)))
3563 {
3564 if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
3565 {
3566 gfc_free_expr (result);
3567 return gfc_copy_expr (as->lower[d-1]);
3568 }
3569
3570 goto returnNull;
3571 }
3572
3573 result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
3574
3575 /* Then, we need to know the extent of the given dimension. */
3576 if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
3577 {
3578 gfc_expr *declared_bound;
3579 int empty_bound;
3580 bool constant_lbound, constant_ubound;
3581
3582 l = as->lower[d-1];
3583 u = as->upper[d-1];
3584
3585 gcc_assert (l != NULL);
3586
3587 constant_lbound = l->expr_type == EXPR_CONSTANT;
3588 constant_ubound = u && u->expr_type == EXPR_CONSTANT;
3589
3590 empty_bound = upper ? 0 : 1;
3591 declared_bound = upper ? u : l;
3592
3593 if ((!upper && !constant_lbound)
3594 || (upper && !constant_ubound))
3595 goto returnNull;
3596
3597 if (!coarray)
3598 {
3599 /* For {L,U}BOUND, the value depends on whether the array
3600 is empty. We can nevertheless simplify if the declared bound
3601 has the same value as that of an empty array, in which case
3602 the result isn't dependent on the array emptyness. */
3603 if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0)
3604 mpz_set_si (result->value.integer, empty_bound);
3605 else if (!constant_lbound || !constant_ubound)
3606 /* Array emptyness can't be determined, we can't simplify. */
3607 goto returnNull;
3608 else if (mpz_cmp (l->value.integer, u->value.integer) > 0)
3609 mpz_set_si (result->value.integer, empty_bound);
3610 else
3611 mpz_set (result->value.integer, declared_bound->value.integer);
3612 }
3613 else
3614 mpz_set (result->value.integer, declared_bound->value.integer);
3615 }
3616 else
3617 {
3618 if (upper)
3619 {
3620 if (!gfc_ref_dimen_size (&ref->u.ar, d - 1, &result->value.integer, NULL))
3621 goto returnNull;
3622 }
3623 else
3624 mpz_set_si (result->value.integer, (long int) 1);
3625 }
3626
3627 done:
3628 return range_check (result, upper ? "UBOUND" : "LBOUND");
3629
3630 returnNull:
3631 gfc_free_expr (result);
3632 return NULL;
3633 }
3634
3635
3636 static gfc_expr *
3637 simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3638 {
3639 gfc_ref *ref;
3640 gfc_array_spec *as;
3641 int d;
3642
3643 if (array->ts.type == BT_CLASS)
3644 return NULL;
3645
3646 if (array->expr_type != EXPR_VARIABLE)
3647 {
3648 as = NULL;
3649 ref = NULL;
3650 goto done;
3651 }
3652
3653 /* Follow any component references. */
3654 as = array->symtree->n.sym->as;
3655 for (ref = array->ref; ref; ref = ref->next)
3656 {
3657 switch (ref->type)
3658 {
3659 case REF_ARRAY:
3660 switch (ref->u.ar.type)
3661 {
3662 case AR_ELEMENT:
3663 as = NULL;
3664 continue;
3665
3666 case AR_FULL:
3667 /* We're done because 'as' has already been set in the
3668 previous iteration. */
3669 goto done;
3670
3671 case AR_UNKNOWN:
3672 return NULL;
3673
3674 case AR_SECTION:
3675 as = ref->u.ar.as;
3676 goto done;
3677 }
3678
3679 gcc_unreachable ();
3680
3681 case REF_COMPONENT:
3682 as = ref->u.c.component->as;
3683 continue;
3684
3685 case REF_SUBSTRING:
3686 continue;
3687 }
3688 }
3689
3690 gcc_unreachable ();
3691
3692 done:
3693
3694 if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
3695 || (as->type == AS_ASSUMED_SHAPE && upper)))
3696 return NULL;
3697
3698 gcc_assert (!as
3699 || (as->type != AS_DEFERRED
3700 && array->expr_type == EXPR_VARIABLE
3701 && !gfc_expr_attr (array).allocatable
3702 && !gfc_expr_attr (array).pointer));
3703
3704 if (dim == NULL)
3705 {
3706 /* Multi-dimensional bounds. */
3707 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3708 gfc_expr *e;
3709 int k;
3710
3711 /* UBOUND(ARRAY) is not valid for an assumed-size array. */
3712 if (upper && as && as->type == AS_ASSUMED_SIZE)
3713 {
3714 /* An error message will be emitted in
3715 check_assumed_size_reference (resolve.c). */
3716 return &gfc_bad_expr;
3717 }
3718
3719 /* Simplify the bounds for each dimension. */
3720 for (d = 0; d < array->rank; d++)
3721 {
3722 bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
3723 false);
3724 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3725 {
3726 int j;
3727
3728 for (j = 0; j < d; j++)
3729 gfc_free_expr (bounds[j]);
3730 return bounds[d];
3731 }
3732 }
3733
3734 /* Allocate the result expression. */
3735 k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
3736 gfc_default_integer_kind);
3737 if (k == -1)
3738 return &gfc_bad_expr;
3739
3740 e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
3741
3742 /* The result is a rank 1 array; its size is the rank of the first
3743 argument to {L,U}BOUND. */
3744 e->rank = 1;
3745 e->shape = gfc_get_shape (1);
3746 mpz_init_set_ui (e->shape[0], array->rank);
3747
3748 /* Create the constructor for this array. */
3749 for (d = 0; d < array->rank; d++)
3750 gfc_constructor_append_expr (&e->value.constructor,
3751 bounds[d], &e->where);
3752
3753 return e;
3754 }
3755 else
3756 {
3757 /* A DIM argument is specified. */
3758 if (dim->expr_type != EXPR_CONSTANT)
3759 return NULL;
3760
3761 d = mpz_get_si (dim->value.integer);
3762
3763 if ((d < 1 || d > array->rank)
3764 || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
3765 {
3766 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3767 return &gfc_bad_expr;
3768 }
3769
3770 if (as && as->type == AS_ASSUMED_RANK)
3771 return NULL;
3772
3773 return simplify_bound_dim (array, kind, d, upper, as, ref, false);
3774 }
3775 }
3776
3777
3778 static gfc_expr *
3779 simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
3780 {
3781 gfc_ref *ref;
3782 gfc_array_spec *as;
3783 int d;
3784
3785 if (array->expr_type != EXPR_VARIABLE)
3786 return NULL;
3787
3788 /* Follow any component references. */
3789 as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
3790 ? array->ts.u.derived->components->as
3791 : array->symtree->n.sym->as;
3792 for (ref = array->ref; ref; ref = ref->next)
3793 {
3794 switch (ref->type)
3795 {
3796 case REF_ARRAY:
3797 switch (ref->u.ar.type)
3798 {
3799 case AR_ELEMENT:
3800 if (ref->u.ar.as->corank > 0)
3801 {
3802 gcc_assert (as == ref->u.ar.as);
3803 goto done;
3804 }
3805 as = NULL;
3806 continue;
3807
3808 case AR_FULL:
3809 /* We're done because 'as' has already been set in the
3810 previous iteration. */
3811 goto done;
3812
3813 case AR_UNKNOWN:
3814 return NULL;
3815
3816 case AR_SECTION:
3817 as = ref->u.ar.as;
3818 goto done;
3819 }
3820
3821 gcc_unreachable ();
3822
3823 case REF_COMPONENT:
3824 as = ref->u.c.component->as;
3825 continue;
3826
3827 case REF_SUBSTRING:
3828 continue;
3829 }
3830 }
3831
3832 if (!as)
3833 gcc_unreachable ();
3834
3835 done:
3836
3837 if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
3838 return NULL;
3839
3840 if (dim == NULL)
3841 {
3842 /* Multi-dimensional cobounds. */
3843 gfc_expr *bounds[GFC_MAX_DIMENSIONS];
3844 gfc_expr *e;
3845 int k;
3846
3847 /* Simplify the cobounds for each dimension. */
3848 for (d = 0; d < as->corank; d++)
3849 {
3850 bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
3851 upper, as, ref, true);
3852 if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
3853 {
3854 int j;
3855
3856 for (j = 0; j < d; j++)
3857 gfc_free_expr (bounds[j]);
3858 return bounds[d];
3859 }
3860 }
3861
3862 /* Allocate the result expression. */
3863 e = gfc_get_expr ();
3864 e->where = array->where;
3865 e->expr_type = EXPR_ARRAY;
3866 e->ts.type = BT_INTEGER;
3867 k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
3868 gfc_default_integer_kind);
3869 if (k == -1)
3870 {
3871 gfc_free_expr (e);
3872 return &gfc_bad_expr;
3873 }
3874 e->ts.kind = k;
3875
3876 /* The result is a rank 1 array; its size is the rank of the first
3877 argument to {L,U}COBOUND. */
3878 e->rank = 1;
3879 e->shape = gfc_get_shape (1);
3880 mpz_init_set_ui (e->shape[0], as->corank);
3881
3882 /* Create the constructor for this array. */
3883 for (d = 0; d < as->corank; d++)
3884 gfc_constructor_append_expr (&e->value.constructor,
3885 bounds[d], &e->where);
3886 return e;
3887 }
3888 else
3889 {
3890 /* A DIM argument is specified. */
3891 if (dim->expr_type != EXPR_CONSTANT)
3892 return NULL;
3893
3894 d = mpz_get_si (dim->value.integer);
3895
3896 if (d < 1 || d > as->corank)
3897 {
3898 gfc_error ("DIM argument at %L is out of bounds", &dim->where);
3899 return &gfc_bad_expr;
3900 }
3901
3902 return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
3903 }
3904 }
3905
3906
3907 gfc_expr *
3908 gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3909 {
3910 return simplify_bound (array, dim, kind, 0);
3911 }
3912
3913
3914 gfc_expr *
3915 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3916 {
3917 return simplify_cobound (array, dim, kind, 0);
3918 }
3919
3920 gfc_expr *
3921 gfc_simplify_leadz (gfc_expr *e)
3922 {
3923 unsigned long lz, bs;
3924 int i;
3925
3926 if (e->expr_type != EXPR_CONSTANT)
3927 return NULL;
3928
3929 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
3930 bs = gfc_integer_kinds[i].bit_size;
3931 if (mpz_cmp_si (e->value.integer, 0) == 0)
3932 lz = bs;
3933 else if (mpz_cmp_si (e->value.integer, 0) < 0)
3934 lz = 0;
3935 else
3936 lz = bs - mpz_sizeinbase (e->value.integer, 2);
3937
3938 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
3939 }
3940
3941
3942 gfc_expr *
3943 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
3944 {
3945 gfc_expr *result;
3946 int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
3947
3948 if (k == -1)
3949 return &gfc_bad_expr;
3950
3951 if (e->expr_type == EXPR_CONSTANT)
3952 {
3953 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3954 mpz_set_si (result->value.integer, e->value.character.length);
3955 return range_check (result, "LEN");
3956 }
3957 else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
3958 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
3959 && e->ts.u.cl->length->ts.type == BT_INTEGER)
3960 {
3961 result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
3962 mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
3963 return range_check (result, "LEN");
3964 }
3965 else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
3966 && e->symtree->n.sym
3967 && e->symtree->n.sym->ts.type != BT_DERIVED
3968 && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
3969 && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
3970 && e->symtree->n.sym->assoc->target->symtree->n.sym
3971 && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
3972
3973 /* The expression in assoc->target points to a ref to the _data component
3974 of the unlimited polymorphic entity. To get the _len component the last
3975 _data ref needs to be stripped and a ref to the _len component added. */
3976 return gfc_get_len_component (e->symtree->n.sym->assoc->target);
3977 else
3978 return NULL;
3979 }
3980
3981
3982 gfc_expr *
3983 gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
3984 {
3985 gfc_expr *result;
3986 int count, len, i;
3987 int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
3988
3989 if (k == -1)
3990 return &gfc_bad_expr;
3991
3992 if (e->expr_type != EXPR_CONSTANT)
3993 return NULL;
3994
3995 len = e->value.character.length;
3996 for (count = 0, i = 1; i <= len; i++)
3997 if (e->value.character.string[len - i] == ' ')
3998 count++;
3999 else
4000 break;
4001
4002 result = gfc_get_int_expr (k, &e->where, len - count);
4003 return range_check (result, "LEN_TRIM");
4004 }
4005
4006 gfc_expr *
4007 gfc_simplify_lgamma (gfc_expr *x)
4008 {
4009 gfc_expr *result;
4010 int sg;
4011
4012 if (x->expr_type != EXPR_CONSTANT)
4013 return NULL;
4014
4015 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4016 mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
4017
4018 return range_check (result, "LGAMMA");
4019 }
4020
4021
4022 gfc_expr *
4023 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
4024 {
4025 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4026 return NULL;
4027
4028 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4029 gfc_compare_string (a, b) >= 0);
4030 }
4031
4032
4033 gfc_expr *
4034 gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
4035 {
4036 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4037 return NULL;
4038
4039 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4040 gfc_compare_string (a, b) > 0);
4041 }
4042
4043
4044 gfc_expr *
4045 gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
4046 {
4047 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4048 return NULL;
4049
4050 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4051 gfc_compare_string (a, b) <= 0);
4052 }
4053
4054
4055 gfc_expr *
4056 gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
4057 {
4058 if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
4059 return NULL;
4060
4061 return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
4062 gfc_compare_string (a, b) < 0);
4063 }
4064
4065
4066 gfc_expr *
4067 gfc_simplify_log (gfc_expr *x)
4068 {
4069 gfc_expr *result;
4070
4071 if (x->expr_type != EXPR_CONSTANT)
4072 return NULL;
4073
4074 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4075
4076 switch (x->ts.type)
4077 {
4078 case BT_REAL:
4079 if (mpfr_sgn (x->value.real) <= 0)
4080 {
4081 gfc_error ("Argument of LOG at %L cannot be less than or equal "
4082 "to zero", &x->where);
4083 gfc_free_expr (result);
4084 return &gfc_bad_expr;
4085 }
4086
4087 mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
4088 break;
4089
4090 case BT_COMPLEX:
4091 if (mpfr_zero_p (mpc_realref (x->value.complex))
4092 && mpfr_zero_p (mpc_imagref (x->value.complex)))
4093 {
4094 gfc_error ("Complex argument of LOG at %L cannot be zero",
4095 &x->where);
4096 gfc_free_expr (result);
4097 return &gfc_bad_expr;
4098 }
4099
4100 gfc_set_model_kind (x->ts.kind);
4101 mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
4102 break;
4103
4104 default:
4105 gfc_internal_error ("gfc_simplify_log: bad type");
4106 }
4107
4108 return range_check (result, "LOG");
4109 }
4110
4111
4112 gfc_expr *
4113 gfc_simplify_log10 (gfc_expr *x)
4114 {
4115 gfc_expr *result;
4116
4117 if (x->expr_type != EXPR_CONSTANT)
4118 return NULL;
4119
4120 if (mpfr_sgn (x->value.real) <= 0)
4121 {
4122 gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
4123 "to zero", &x->where);
4124 return &gfc_bad_expr;
4125 }
4126
4127 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
4128 mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
4129
4130 return range_check (result, "LOG10");
4131 }
4132
4133
4134 gfc_expr *
4135 gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
4136 {
4137 int kind;
4138
4139 kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
4140 if (kind < 0)
4141 return &gfc_bad_expr;
4142
4143 if (e->expr_type != EXPR_CONSTANT)
4144 return NULL;
4145
4146 return gfc_get_logical_expr (kind, &e->where, e->value.logical);
4147 }
4148
4149
4150 gfc_expr*
4151 gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
4152 {
4153 gfc_expr *result;
4154 int row, result_rows, col, result_columns;
4155 int stride_a, offset_a, stride_b, offset_b;
4156
4157 if (!is_constant_array_expr (matrix_a)
4158 || !is_constant_array_expr (matrix_b))
4159 return NULL;
4160
4161 gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
4162 result = gfc_get_array_expr (matrix_a->ts.type,
4163 matrix_a->ts.kind,
4164 &matrix_a->where);
4165
4166 if (matrix_a->rank == 1 && matrix_b->rank == 2)
4167 {
4168 result_rows = 1;
4169 result_columns = mpz_get_si (matrix_b->shape[1]);
4170 stride_a = 1;
4171 stride_b = mpz_get_si (matrix_b->shape[0]);
4172
4173 result->rank = 1;
4174 result->shape = gfc_get_shape (result->rank);
4175 mpz_init_set_si (result->shape[0], result_columns);
4176 }
4177 else if (matrix_a->rank == 2 && matrix_b->rank == 1)
4178 {
4179 result_rows = mpz_get_si (matrix_a->shape[0]);
4180 result_columns = 1;
4181 stride_a = mpz_get_si (matrix_a->shape[0]);
4182 stride_b = 1;
4183
4184 result->rank = 1;
4185 result->shape = gfc_get_shape (result->rank);
4186 mpz_init_set_si (result->shape[0], result_rows);
4187 }
4188 else if (matrix_a->rank == 2 && matrix_b->rank == 2)
4189 {
4190 result_rows = mpz_get_si (matrix_a->shape[0]);
4191 result_columns = mpz_get_si (matrix_b->shape[1]);
4192 stride_a = mpz_get_si (matrix_a->shape[0]);
4193 stride_b = mpz_get_si (matrix_b->shape[0]);
4194
4195 result->rank = 2;
4196 result->shape = gfc_get_shape (result->rank);
4197 mpz_init_set_si (result->shape[0], result_rows);
4198 mpz_init_set_si (result->shape[1], result_columns);
4199 }
4200 else
4201 gcc_unreachable();
4202
4203 offset_a = offset_b = 0;
4204 for (col = 0; col < result_columns; ++col)
4205 {
4206 offset_a = 0;
4207
4208 for (row = 0; row < result_rows; ++row)
4209 {
4210 gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
4211 matrix_b, 1, offset_b, false);
4212 gfc_constructor_append_expr (&result->value.constructor,
4213 e, NULL);
4214
4215 offset_a += 1;
4216 }
4217
4218 offset_b += stride_b;
4219 }
4220
4221 return result;
4222 }
4223
4224
4225 gfc_expr *
4226 gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
4227 {
4228 gfc_expr *result;
4229 int kind, arg, k;
4230 const char *s;
4231
4232 if (i->expr_type != EXPR_CONSTANT)
4233 return NULL;
4234
4235 kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
4236 if (kind == -1)
4237 return &gfc_bad_expr;
4238 k = gfc_validate_kind (BT_INTEGER, kind, false);
4239
4240 s = gfc_extract_int (i, &arg);
4241 gcc_assert (!s);
4242
4243 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4244
4245 /* MASKR(n) = 2^n - 1 */
4246 mpz_set_ui (result->value.integer, 1);
4247 mpz_mul_2exp (result->value.integer, result->value.integer, arg);
4248 mpz_sub_ui (result->value.integer, result->value.integer, 1);
4249
4250 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4251
4252 return result;
4253 }
4254
4255
4256 gfc_expr *
4257 gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
4258 {
4259 gfc_expr *result;
4260 int kind, arg, k;
4261 const char *s;
4262 mpz_t z;
4263
4264 if (i->expr_type != EXPR_CONSTANT)
4265 return NULL;
4266
4267 kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
4268 if (kind == -1)
4269 return &gfc_bad_expr;
4270 k = gfc_validate_kind (BT_INTEGER, kind, false);
4271
4272 s = gfc_extract_int (i, &arg);
4273 gcc_assert (!s);
4274
4275 result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
4276
4277 /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
4278 mpz_init_set_ui (z, 1);
4279 mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
4280 mpz_set_ui (result->value.integer, 1);
4281 mpz_mul_2exp (result->value.integer, result->value.integer,
4282 gfc_integer_kinds[k].bit_size - arg);
4283 mpz_sub (result->value.integer, z, result->value.integer);
4284 mpz_clear (z);
4285
4286 gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
4287
4288 return result;
4289 }
4290
4291
4292 gfc_expr *
4293 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4294 {
4295 gfc_expr * result;
4296 gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
4297
4298 if (mask->expr_type == EXPR_CONSTANT)
4299 return gfc_get_parentheses (gfc_copy_expr (mask->value.logical
4300 ? tsource : fsource));
4301
4302 if (!mask->rank || !is_constant_array_expr (mask)
4303 || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
4304 return NULL;
4305
4306 result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
4307 &tsource->where);
4308 if (tsource->ts.type == BT_DERIVED)
4309 result->ts.u.derived = tsource->ts.u.derived;
4310 else if (tsource->ts.type == BT_CHARACTER)
4311 result->ts.u.cl = tsource->ts.u.cl;
4312
4313 tsource_ctor = gfc_constructor_first (tsource->value.constructor);
4314 fsource_ctor = gfc_constructor_first (fsource->value.constructor);
4315 mask_ctor = gfc_constructor_first (mask->value.constructor);
4316
4317 while (mask_ctor)
4318 {
4319 if (mask_ctor->expr->value.logical)
4320 gfc_constructor_append_expr (&result->value.constructor,
4321 gfc_copy_expr (tsource_ctor->expr),
4322 NULL);
4323 else
4324 gfc_constructor_append_expr (&result->value.constructor,
4325 gfc_copy_expr (fsource_ctor->expr),
4326 NULL);
4327 tsource_ctor = gfc_constructor_next (tsource_ctor);
4328 fsource_ctor = gfc_constructor_next (fsource_ctor);
4329 mask_ctor = gfc_constructor_next (mask_ctor);
4330 }
4331
4332 result->shape = gfc_get_shape (1);
4333 gfc_array_size (result, &result->shape[0]);
4334
4335 return result;
4336 }
4337
4338
4339 gfc_expr *
4340 gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
4341 {
4342 mpz_t arg1, arg2, mask;
4343 gfc_expr *result;
4344
4345 if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
4346 || mask_expr->expr_type != EXPR_CONSTANT)
4347 return NULL;
4348
4349 result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
4350
4351 /* Convert all argument to unsigned. */
4352 mpz_init_set (arg1, i->value.integer);
4353 mpz_init_set (arg2, j->value.integer);
4354 mpz_init_set (mask, mask_expr->value.integer);
4355
4356 /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
4357 mpz_and (arg1, arg1, mask);
4358 mpz_com (mask, mask);
4359 mpz_and (arg2, arg2, mask);
4360 mpz_ior (result->value.integer, arg1, arg2);
4361
4362 mpz_clear (arg1);
4363 mpz_clear (arg2);
4364 mpz_clear (mask);
4365
4366 return result;
4367 }
4368
4369
4370 /* Selects between current value and extremum for simplify_min_max
4371 and simplify_minval_maxval. */
4372 static void
4373 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
4374 {
4375 switch (arg->ts.type)
4376 {
4377 case BT_INTEGER:
4378 if (mpz_cmp (arg->value.integer,
4379 extremum->value.integer) * sign > 0)
4380 mpz_set (extremum->value.integer, arg->value.integer);
4381 break;
4382
4383 case BT_REAL:
4384 /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
4385 if (sign > 0)
4386 mpfr_max (extremum->value.real, extremum->value.real,
4387 arg->value.real, GFC_RND_MODE);
4388 else
4389 mpfr_min (extremum->value.real, extremum->value.real,
4390 arg->value.real, GFC_RND_MODE);
4391 break;
4392
4393 case BT_CHARACTER:
4394 #define LENGTH(x) ((x)->value.character.length)
4395 #define STRING(x) ((x)->value.character.string)
4396 if (LENGTH (extremum) < LENGTH(arg))
4397 {
4398 gfc_char_t *tmp = STRING(extremum);
4399
4400 STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
4401 memcpy (STRING(extremum), tmp,
4402 LENGTH(extremum) * sizeof (gfc_char_t));
4403 gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
4404 LENGTH(arg) - LENGTH(extremum));
4405 STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
4406 LENGTH(extremum) = LENGTH(arg);
4407 free (tmp);
4408 }
4409
4410 if (gfc_compare_string (arg, extremum) * sign > 0)
4411 {
4412 free (STRING(extremum));
4413 STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
4414 memcpy (STRING(extremum), STRING(arg),
4415 LENGTH(arg) * sizeof (gfc_char_t));
4416 gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
4417 LENGTH(extremum) - LENGTH(arg));
4418 STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
4419 }
4420 #undef LENGTH
4421 #undef STRING
4422 break;
4423
4424 default:
4425 gfc_internal_error ("simplify_min_max(): Bad type in arglist");
4426 }
4427 }
4428
4429
4430 /* This function is special since MAX() can take any number of
4431 arguments. The simplified expression is a rewritten version of the
4432 argument list containing at most one constant element. Other
4433 constant elements are deleted. Because the argument list has
4434 already been checked, this function always succeeds. sign is 1 for
4435 MAX(), -1 for MIN(). */
4436
4437 static gfc_expr *
4438 simplify_min_max (gfc_expr *expr, int sign)
4439 {
4440 gfc_actual_arglist *arg, *last, *extremum;
4441 gfc_intrinsic_sym * specific;
4442
4443 last = NULL;
4444 extremum = NULL;
4445 specific = expr->value.function.isym;
4446
4447 arg = expr->value.function.actual;
4448
4449 for (; arg; last = arg, arg = arg->next)
4450 {
4451 if (arg->expr->expr_type != EXPR_CONSTANT)
4452 continue;
4453
4454 if (extremum == NULL)
4455 {
4456 extremum = arg;
4457 continue;
4458 }
4459
4460 min_max_choose (arg->expr, extremum->expr, sign);
4461
4462 /* Delete the extra constant argument. */
4463 last->next = arg->next;
4464
4465 arg->next = NULL;
4466 gfc_free_actual_arglist (arg);
4467 arg = last;
4468 }
4469
4470 /* If there is one value left, replace the function call with the
4471 expression. */
4472 if (expr->value.function.actual->next != NULL)
4473 return NULL;
4474
4475 /* Convert to the correct type and kind. */
4476 if (expr->ts.type != BT_UNKNOWN)
4477 return gfc_convert_constant (expr->value.function.actual->expr,
4478 expr->ts.type, expr->ts.kind);
4479
4480 if (specific->ts.type != BT_UNKNOWN)
4481 return gfc_convert_constant (expr->value.function.actual->expr,
4482 specific->ts.type, specific->ts.kind);
4483
4484 return gfc_copy_expr (expr->value.function.actual->expr);
4485 }
4486
4487
4488 gfc_expr *
4489 gfc_simplify_min (gfc_expr *e)
4490 {
4491 return simplify_min_max (e, -1);
4492 }
4493
4494
4495 gfc_expr *
4496 gfc_simplify_max (gfc_expr *e)
4497 {
4498 return simplify_min_max (e, 1);
4499 }
4500
4501
4502 /* This is a simplified version of simplify_min_max to provide
4503 simplification of minval and maxval for a vector. */
4504
4505 static gfc_expr *
4506 simplify_minval_maxval (gfc_expr *expr, int sign)
4507 {
4508 gfc_constructor *c, *extremum;
4509 gfc_intrinsic_sym * specific;
4510
4511 extremum = NULL;
4512 specific = expr->value.function.isym;
4513
4514 for (c = gfc_constructor_first (expr->value.constructor);
4515 c; c = gfc_constructor_next (c))
4516 {
4517 if (c->expr->expr_type != EXPR_CONSTANT)
4518 return NULL;
4519
4520 if (extremum == NULL)
4521 {
4522 extremum = c;
4523 continue;
4524 }
4525
4526 min_max_choose (c->expr, extremum->expr, sign);
4527 }
4528
4529 if (extremum == NULL)
4530 return NULL;
4531
4532 /* Convert to the correct type and kind. */
4533 if (expr->ts.type != BT_UNKNOWN)
4534 return gfc_convert_constant (extremum->expr,
4535 expr->ts.type, expr->ts.kind);
4536
4537 if (specific->ts.type != BT_UNKNOWN)
4538 return gfc_convert_constant (extremum->expr,
4539 specific->ts.type, specific->ts.kind);
4540
4541 return gfc_copy_expr (extremum->expr);
4542 }
4543
4544
4545 gfc_expr *
4546 gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4547 {
4548 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4549 return NULL;
4550
4551 return simplify_minval_maxval (array, -1);
4552 }
4553
4554
4555 gfc_expr *
4556 gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
4557 {
4558 if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
4559 return NULL;
4560
4561 return simplify_minval_maxval (array, 1);
4562 }
4563
4564
4565 gfc_expr *
4566 gfc_simplify_maxexponent (gfc_expr *x)
4567 {
4568 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4569 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4570 gfc_real_kinds[i].max_exponent);
4571 }
4572
4573
4574 gfc_expr *
4575 gfc_simplify_minexponent (gfc_expr *x)
4576 {
4577 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
4578 return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
4579 gfc_real_kinds[i].min_exponent);
4580 }
4581
4582
4583 gfc_expr *
4584 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
4585 {
4586 gfc_expr *result;
4587 int kind;
4588
4589 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4590 return NULL;
4591
4592 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4593 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4594
4595 switch (a->ts.type)
4596 {
4597 case BT_INTEGER:
4598 if (mpz_cmp_ui (p->value.integer, 0) == 0)
4599 {
4600 /* Result is processor-dependent. */
4601 gfc_error ("Second argument MOD at %L is zero", &a->where);
4602 gfc_free_expr (result);
4603 return &gfc_bad_expr;
4604 }
4605 mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
4606 break;
4607
4608 case BT_REAL:
4609 if (mpfr_cmp_ui (p->value.real, 0) == 0)
4610 {
4611 /* Result is processor-dependent. */
4612 gfc_error ("Second argument of MOD at %L is zero", &p->where);
4613 gfc_free_expr (result);
4614 return &gfc_bad_expr;
4615 }
4616
4617 gfc_set_model_kind (kind);
4618 mpfr_fmod (result->value.real, a->value.real, p->value.real,
4619 GFC_RND_MODE);
4620 break;
4621
4622 default:
4623 gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
4624 }
4625
4626 return range_check (result, "MOD");
4627 }
4628
4629
4630 gfc_expr *
4631 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
4632 {
4633 gfc_expr *result;
4634 int kind;
4635
4636 if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
4637 return NULL;
4638
4639 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
4640 result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
4641
4642 switch (a->ts.type)
4643 {
4644 case BT_INTEGER:
4645 if (mpz_cmp_ui (p->value.integer, 0) == 0)
4646 {
4647 /* Result is processor-dependent. This processor just opts
4648 to not handle it at all. */
4649 gfc_error ("Second argument of MODULO at %L is zero", &a->where);
4650 gfc_free_expr (result);
4651 return &gfc_bad_expr;
4652 }
4653 mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
4654
4655 break;
4656
4657 case BT_REAL:
4658 if (mpfr_cmp_ui (p->value.real, 0) == 0)
4659 {
4660 /* Result is processor-dependent. */
4661 gfc_error ("Second argument of MODULO at %L is zero", &p->where);
4662 gfc_free_expr (result);
4663 return &gfc_bad_expr;
4664 }
4665
4666 gfc_set_model_kind (kind);
4667 mpfr_fmod (result->value.real, a->value.real, p->value.real,
4668 GFC_RND_MODE);
4669 if (mpfr_cmp_ui (result->value.real, 0) != 0)
4670 {
4671 if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
4672 mpfr_add (result->value.real, result->value.real, p->value.real,
4673 GFC_RND_MODE);
4674 }
4675 else
4676 mpfr_copysign (result->value.real, result->value.real,
4677 p->value.real, GFC_RND_MODE);
4678 break;
4679
4680 default:
4681 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
4682 }
4683
4684 return range_check (result, "MODULO");
4685 }
4686
4687
4688 gfc_expr *
4689 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
4690 {
4691 gfc_expr *result;
4692 mp_exp_t emin, emax;
4693 int kind;
4694
4695 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
4696 return NULL;
4697
4698 result = gfc_copy_expr (x);
4699
4700 /* Save current values of emin and emax. */
4701 emin = mpfr_get_emin ();
4702 emax = mpfr_get_emax ();
4703
4704 /* Set emin and emax for the current model number. */
4705 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
4706 mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
4707 mpfr_get_prec(result->value.real) + 1);
4708 mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
4709 mpfr_check_range (result->value.real, 0, GMP_RNDU);
4710
4711 if (mpfr_sgn (s->value.real) > 0)
4712 {
4713 mpfr_nextabove (result->value.real);
4714 mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
4715 }
4716 else
4717 {
4718 mpfr_nextbelow (result->value.real);
4719 mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
4720 }
4721
4722 mpfr_set_emin (emin);
4723 mpfr_set_emax (emax);
4724
4725 /* Only NaN can occur. Do not use range check as it gives an
4726 error for denormal numbers. */
4727 if (mpfr_nan_p (result->value.real) && flag_range_check)
4728 {
4729 gfc_error ("Result of NEAREST is NaN at %L", &result->where);
4730 gfc_free_expr (result);
4731 return &gfc_bad_expr;
4732 }
4733
4734 return result;
4735 }
4736
4737
4738 static gfc_expr *
4739 simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
4740 {
4741 gfc_expr *itrunc, *result;
4742 int kind;
4743
4744 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
4745 if (kind == -1)
4746 return &gfc_bad_expr;
4747
4748 if (e->expr_type != EXPR_CONSTANT)
4749 return NULL;
4750
4751 itrunc = gfc_copy_expr (e);
4752 mpfr_round (itrunc->value.real, e->value.real);
4753
4754 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
4755 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
4756
4757 gfc_free_expr (itrunc);
4758
4759 return range_check (result, name);
4760 }
4761
4762
4763 gfc_expr *
4764 gfc_simplify_new_line (gfc_expr *e)
4765 {
4766 gfc_expr *result;
4767
4768 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
4769 result->value.character.string[0] = '\n';
4770
4771 return result;
4772 }
4773
4774
4775 gfc_expr *
4776 gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
4777 {
4778 return simplify_nint ("NINT", e, k);
4779 }
4780
4781
4782 gfc_expr *
4783 gfc_simplify_idnint (gfc_expr *e)
4784 {
4785 return simplify_nint ("IDNINT", e, NULL);
4786 }
4787
4788
4789 static gfc_expr *
4790 add_squared (gfc_expr *result, gfc_expr *e)
4791 {
4792 mpfr_t tmp;
4793
4794 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4795 gcc_assert (result->ts.type == BT_REAL
4796 && result->expr_type == EXPR_CONSTANT);
4797
4798 gfc_set_model_kind (result->ts.kind);
4799 mpfr_init (tmp);
4800 mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
4801 mpfr_add (result->value.real, result->value.real, tmp,
4802 GFC_RND_MODE);
4803 mpfr_clear (tmp);
4804
4805 return result;
4806 }
4807
4808
4809 static gfc_expr *
4810 do_sqrt (gfc_expr *result, gfc_expr *e)
4811 {
4812 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
4813 gcc_assert (result->ts.type == BT_REAL
4814 && result->expr_type == EXPR_CONSTANT);
4815
4816 mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
4817 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4818 return result;
4819 }
4820
4821
4822 gfc_expr *
4823 gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
4824 {
4825 gfc_expr *result;
4826
4827 if (!is_constant_array_expr (e)
4828 || (dim != NULL && !gfc_is_constant_expr (dim)))
4829 return NULL;
4830
4831 result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
4832 init_result_expr (result, 0, NULL);
4833
4834 if (!dim || e->rank == 1)
4835 {
4836 result = simplify_transformation_to_scalar (result, e, NULL,
4837 add_squared);
4838 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
4839 }
4840 else
4841 result = simplify_transformation_to_array (result, e, dim, NULL,
4842 add_squared, &do_sqrt);
4843
4844 return result;
4845 }
4846
4847
4848 gfc_expr *
4849 gfc_simplify_not (gfc_expr *e)
4850 {
4851 gfc_expr *result;
4852
4853 if (e->expr_type != EXPR_CONSTANT)
4854 return NULL;
4855
4856 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
4857 mpz_com (result->value.integer, e->value.integer);
4858
4859 return range_check (result, "NOT");
4860 }
4861
4862
4863 gfc_expr *
4864 gfc_simplify_null (gfc_expr *mold)
4865 {
4866 gfc_expr *result;
4867
4868 if (mold)
4869 {
4870 result = gfc_copy_expr (mold);
4871 result->expr_type = EXPR_NULL;
4872 }
4873 else
4874 result = gfc_get_null_expr (NULL);
4875
4876 return result;
4877 }
4878
4879
4880 gfc_expr *
4881 gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
4882 {
4883 gfc_expr *result;
4884
4885 if (flag_coarray == GFC_FCOARRAY_NONE)
4886 {
4887 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
4888 return &gfc_bad_expr;
4889 }
4890
4891 if (flag_coarray != GFC_FCOARRAY_SINGLE)
4892 return NULL;
4893
4894 if (failed && failed->expr_type != EXPR_CONSTANT)
4895 return NULL;
4896
4897 /* FIXME: gfc_current_locus is wrong. */
4898 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
4899 &gfc_current_locus);
4900
4901 if (failed && failed->value.logical != 0)
4902 mpz_set_si (result->value.integer, 0);
4903 else
4904 mpz_set_si (result->value.integer, 1);
4905
4906 return result;
4907 }
4908
4909
4910 gfc_expr *
4911 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
4912 {
4913 gfc_expr *result;
4914 int kind;
4915
4916 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
4917 return NULL;
4918
4919 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
4920
4921 switch (x->ts.type)
4922 {
4923 case BT_INTEGER:
4924 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
4925 mpz_ior (result->value.integer, x->value.integer, y->value.integer);
4926 return range_check (result, "OR");
4927
4928 case BT_LOGICAL:
4929 return gfc_get_logical_expr (kind, &x->where,
4930 x->value.logical || y->value.logical);
4931 default:
4932 gcc_unreachable();
4933 }
4934 }
4935
4936
4937 gfc_expr *
4938 gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
4939 {
4940 gfc_expr *result;
4941 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
4942
4943 if (!is_constant_array_expr (array)
4944 || !is_constant_array_expr (vector)
4945 || (!gfc_is_constant_expr (mask)
4946 && !is_constant_array_expr (mask)))
4947 return NULL;
4948
4949 result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
4950 if (array->ts.type == BT_DERIVED)
4951 result->ts.u.derived = array->ts.u.derived;
4952
4953 array_ctor = gfc_constructor_first (array->value.constructor);
4954 vector_ctor = vector
4955 ? gfc_constructor_first (vector->value.constructor)
4956 : NULL;
4957
4958 if (mask->expr_type == EXPR_CONSTANT
4959 && mask->value.logical)
4960 {
4961 /* Copy all elements of ARRAY to RESULT. */
4962 while (array_ctor)
4963 {
4964 gfc_constructor_append_expr (&result->value.constructor,
4965 gfc_copy_expr (array_ctor->expr),
4966 NULL);
4967
4968 array_ctor = gfc_constructor_next (array_ctor);
4969 vector_ctor = gfc_constructor_next (vector_ctor);
4970 }
4971 }
4972 else if (mask->expr_type == EXPR_ARRAY)
4973 {
4974 /* Copy only those elements of ARRAY to RESULT whose
4975 MASK equals .TRUE.. */
4976 mask_ctor = gfc_constructor_first (mask->value.constructor);
4977 while (mask_ctor)
4978 {
4979 if (mask_ctor->expr->value.logical)
4980 {
4981 gfc_constructor_append_expr (&result->value.constructor,
4982 gfc_copy_expr (array_ctor->expr),
4983 NULL);
4984 vector_ctor = gfc_constructor_next (vector_ctor);
4985 }
4986
4987 array_ctor = gfc_constructor_next (array_ctor);
4988 mask_ctor = gfc_constructor_next (mask_ctor);
4989 }
4990 }
4991
4992 /* Append any left-over elements from VECTOR to RESULT. */
4993 while (vector_ctor)
4994 {
4995 gfc_constructor_append_expr (&result->value.constructor,
4996 gfc_copy_expr (vector_ctor->expr),
4997 NULL);
4998 vector_ctor = gfc_constructor_next (vector_ctor);
4999 }
5000
5001 result->shape = gfc_get_shape (1);
5002 gfc_array_size (result, &result->shape[0]);
5003
5004 if (array->ts.type == BT_CHARACTER)
5005 result->ts.u.cl = array->ts.u.cl;
5006
5007 return result;
5008 }
5009
5010
5011 static gfc_expr *
5012 do_xor (gfc_expr *result, gfc_expr *e)
5013 {
5014 gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
5015 gcc_assert (result->ts.type == BT_LOGICAL
5016 && result->expr_type == EXPR_CONSTANT);
5017
5018 result->value.logical = result->value.logical != e->value.logical;
5019 return result;
5020 }
5021
5022
5023
5024 gfc_expr *
5025 gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
5026 {
5027 return simplify_transformation (e, dim, NULL, 0, do_xor);
5028 }
5029
5030
5031 gfc_expr *
5032 gfc_simplify_popcnt (gfc_expr *e)
5033 {
5034 int res, k;
5035 mpz_t x;
5036
5037 if (e->expr_type != EXPR_CONSTANT)
5038 return NULL;
5039
5040 k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5041
5042 /* Convert argument to unsigned, then count the '1' bits. */
5043 mpz_init_set (x, e->value.integer);
5044 convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
5045 res = mpz_popcount (x);
5046 mpz_clear (x);
5047
5048 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
5049 }
5050
5051
5052 gfc_expr *
5053 gfc_simplify_poppar (gfc_expr *e)
5054 {
5055 gfc_expr *popcnt;
5056 const char *s;
5057 int i;
5058
5059 if (e->expr_type != EXPR_CONSTANT)
5060 return NULL;
5061
5062 popcnt = gfc_simplify_popcnt (e);
5063 gcc_assert (popcnt);
5064
5065 s = gfc_extract_int (popcnt, &i);
5066 gcc_assert (!s);
5067
5068 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
5069 }
5070
5071
5072 gfc_expr *
5073 gfc_simplify_precision (gfc_expr *e)
5074 {
5075 int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5076 return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
5077 gfc_real_kinds[i].precision);
5078 }
5079
5080
5081 gfc_expr *
5082 gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
5083 {
5084 return simplify_transformation (array, dim, mask, 1, gfc_multiply);
5085 }
5086
5087
5088 gfc_expr *
5089 gfc_simplify_radix (gfc_expr *e)
5090 {
5091 int i;
5092 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5093
5094 switch (e->ts.type)
5095 {
5096 case BT_INTEGER:
5097 i = gfc_integer_kinds[i].radix;
5098 break;
5099
5100 case BT_REAL:
5101 i = gfc_real_kinds[i].radix;
5102 break;
5103
5104 default:
5105 gcc_unreachable ();
5106 }
5107
5108 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
5109 }
5110
5111
5112 gfc_expr *
5113 gfc_simplify_range (gfc_expr *e)
5114 {
5115 int i;
5116 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
5117
5118 switch (e->ts.type)
5119 {
5120 case BT_INTEGER:
5121 i = gfc_integer_kinds[i].range;
5122 break;
5123
5124 case BT_REAL:
5125 case BT_COMPLEX:
5126 i = gfc_real_kinds[i].range;
5127 break;
5128
5129 default:
5130 gcc_unreachable ();
5131 }
5132
5133 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
5134 }
5135
5136
5137 gfc_expr *
5138 gfc_simplify_rank (gfc_expr *e)
5139 {
5140 /* Assumed rank. */
5141 if (e->rank == -1)
5142 return NULL;
5143
5144 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
5145 }
5146
5147
5148 gfc_expr *
5149 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
5150 {
5151 gfc_expr *result = NULL;
5152 int kind;
5153
5154 if (e->ts.type == BT_COMPLEX)
5155 kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
5156 else
5157 kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
5158
5159 if (kind == -1)
5160 return &gfc_bad_expr;
5161
5162 if (e->expr_type != EXPR_CONSTANT)
5163 return NULL;
5164
5165 if (convert_boz (e, kind) == &gfc_bad_expr)
5166 return &gfc_bad_expr;
5167
5168 result = gfc_convert_constant (e, BT_REAL, kind);
5169 if (result == &gfc_bad_expr)
5170 return &gfc_bad_expr;
5171
5172 return range_check (result, "REAL");
5173 }
5174
5175
5176 gfc_expr *
5177 gfc_simplify_realpart (gfc_expr *e)
5178 {
5179 gfc_expr *result;
5180
5181 if (e->expr_type != EXPR_CONSTANT)
5182 return NULL;
5183
5184 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
5185 mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
5186
5187 return range_check (result, "REALPART");
5188 }
5189
5190 gfc_expr *
5191 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
5192 {
5193 gfc_expr *result;
5194 int i, j, len, ncop, nlen;
5195 mpz_t ncopies;
5196 bool have_length = false;
5197
5198 /* If NCOPIES isn't a constant, there's nothing we can do. */
5199 if (n->expr_type != EXPR_CONSTANT)
5200 return NULL;
5201
5202 /* If NCOPIES is negative, it's an error. */
5203 if (mpz_sgn (n->value.integer) < 0)
5204 {
5205 gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
5206 &n->where);
5207 return &gfc_bad_expr;
5208 }
5209
5210 /* If we don't know the character length, we can do no more. */
5211 if (e->ts.u.cl && e->ts.u.cl->length
5212 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5213 {
5214 len = mpz_get_si (e->ts.u.cl->length->value.integer);
5215 have_length = true;
5216 }
5217 else if (e->expr_type == EXPR_CONSTANT
5218 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
5219 {
5220 len = e->value.character.length;
5221 }
5222 else
5223 return NULL;
5224
5225 /* If the source length is 0, any value of NCOPIES is valid
5226 and everything behaves as if NCOPIES == 0. */
5227 mpz_init (ncopies);
5228 if (len == 0)
5229 mpz_set_ui (ncopies, 0);
5230 else
5231 mpz_set (ncopies, n->value.integer);
5232
5233 /* Check that NCOPIES isn't too large. */
5234 if (len)
5235 {
5236 mpz_t max, mlen;
5237 int i;
5238
5239 /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
5240 mpz_init (max);
5241 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5242
5243 if (have_length)
5244 {
5245 mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
5246 e->ts.u.cl->length->value.integer);
5247 }
5248 else
5249 {
5250 mpz_init_set_si (mlen, len);
5251 mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
5252 mpz_clear (mlen);
5253 }
5254
5255 /* The check itself. */
5256 if (mpz_cmp (ncopies, max) > 0)
5257 {
5258 mpz_clear (max);
5259 mpz_clear (ncopies);
5260 gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
5261 &n->where);
5262 return &gfc_bad_expr;
5263 }
5264
5265 mpz_clear (max);
5266 }
5267 mpz_clear (ncopies);
5268
5269 /* For further simplification, we need the character string to be
5270 constant. */
5271 if (e->expr_type != EXPR_CONSTANT)
5272 return NULL;
5273
5274 if (len ||
5275 (e->ts.u.cl->length &&
5276 mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
5277 {
5278 const char *res = gfc_extract_int (n, &ncop);
5279 gcc_assert (res == NULL);
5280 }
5281 else
5282 ncop = 0;
5283
5284 if (ncop == 0)
5285 return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
5286
5287 len = e->value.character.length;
5288 nlen = ncop * len;
5289
5290 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
5291 for (i = 0; i < ncop; i++)
5292 for (j = 0; j < len; j++)
5293 result->value.character.string[j+i*len]= e->value.character.string[j];
5294
5295 result->value.character.string[nlen] = '\0'; /* For debugger */
5296 return result;
5297 }
5298
5299
5300 /* This one is a bear, but mainly has to do with shuffling elements. */
5301
5302 gfc_expr *
5303 gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
5304 gfc_expr *pad, gfc_expr *order_exp)
5305 {
5306 int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
5307 int i, rank, npad, x[GFC_MAX_DIMENSIONS];
5308 mpz_t index, size;
5309 unsigned long j;
5310 size_t nsource;
5311 gfc_expr *e, *result;
5312
5313 /* Check that argument expression types are OK. */
5314 if (!is_constant_array_expr (source)
5315 || !is_constant_array_expr (shape_exp)
5316 || !is_constant_array_expr (pad)
5317 || !is_constant_array_expr (order_exp))
5318 return NULL;
5319
5320 if (source->shape == NULL)
5321 return NULL;
5322
5323 /* Proceed with simplification, unpacking the array. */
5324
5325 mpz_init (index);
5326 rank = 0;
5327
5328 for (;;)
5329 {
5330 e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
5331 if (e == NULL)
5332 break;
5333
5334 gfc_extract_int (e, &shape[rank]);
5335
5336 gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
5337 gcc_assert (shape[rank] >= 0);
5338
5339 rank++;
5340 }
5341
5342 gcc_assert (rank > 0);
5343
5344 /* Now unpack the order array if present. */
5345 if (order_exp == NULL)
5346 {
5347 for (i = 0; i < rank; i++)
5348 order[i] = i;
5349 }
5350 else
5351 {
5352 for (i = 0; i < rank; i++)
5353 x[i] = 0;
5354
5355 for (i = 0; i < rank; i++)
5356 {
5357 e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
5358 gcc_assert (e);
5359
5360 gfc_extract_int (e, &order[i]);
5361
5362 gcc_assert (order[i] >= 1 && order[i] <= rank);
5363 order[i]--;
5364 gcc_assert (x[order[i]] == 0);
5365 x[order[i]] = 1;
5366 }
5367 }
5368
5369 /* Count the elements in the source and padding arrays. */
5370
5371 npad = 0;
5372 if (pad != NULL)
5373 {
5374 gfc_array_size (pad, &size);
5375 npad = mpz_get_ui (size);
5376 mpz_clear (size);
5377 }
5378
5379 gfc_array_size (source, &size);
5380 nsource = mpz_get_ui (size);
5381 mpz_clear (size);
5382
5383 /* If it weren't for that pesky permutation we could just loop
5384 through the source and round out any shortage with pad elements.
5385 But no, someone just had to have the compiler do something the
5386 user should be doing. */
5387
5388 for (i = 0; i < rank; i++)
5389 x[i] = 0;
5390
5391 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
5392 &source->where);
5393 if (source->ts.type == BT_DERIVED)
5394 result->ts.u.derived = source->ts.u.derived;
5395 result->rank = rank;
5396 result->shape = gfc_get_shape (rank);
5397 for (i = 0; i < rank; i++)
5398 mpz_init_set_ui (result->shape[i], shape[i]);
5399
5400 while (nsource > 0 || npad > 0)
5401 {
5402 /* Figure out which element to extract. */
5403 mpz_set_ui (index, 0);
5404
5405 for (i = rank - 1; i >= 0; i--)
5406 {
5407 mpz_add_ui (index, index, x[order[i]]);
5408 if (i != 0)
5409 mpz_mul_ui (index, index, shape[order[i - 1]]);
5410 }
5411
5412 if (mpz_cmp_ui (index, INT_MAX) > 0)
5413 gfc_internal_error ("Reshaped array too large at %C");
5414
5415 j = mpz_get_ui (index);
5416
5417 if (j < nsource)
5418 e = gfc_constructor_lookup_expr (source->value.constructor, j);
5419 else
5420 {
5421 if (npad <= 0)
5422 {
5423 mpz_clear (index);
5424 return NULL;
5425 }
5426 j = j - nsource;
5427 j = j % npad;
5428 e = gfc_constructor_lookup_expr (pad->value.constructor, j);
5429 }
5430 gcc_assert (e);
5431
5432 gfc_constructor_append_expr (&result->value.constructor,
5433 gfc_copy_expr (e), &e->where);
5434
5435 /* Calculate the next element. */
5436 i = 0;
5437
5438 inc:
5439 if (++x[i] < shape[i])
5440 continue;
5441 x[i++] = 0;
5442 if (i < rank)
5443 goto inc;
5444
5445 break;
5446 }
5447
5448 mpz_clear (index);
5449
5450 return result;
5451 }
5452
5453
5454 gfc_expr *
5455 gfc_simplify_rrspacing (gfc_expr *x)
5456 {
5457 gfc_expr *result;
5458 int i;
5459 long int e, p;
5460
5461 if (x->expr_type != EXPR_CONSTANT)
5462 return NULL;
5463
5464 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
5465
5466 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5467
5468 /* RRSPACING(+/- 0.0) = 0.0 */
5469 if (mpfr_zero_p (x->value.real))
5470 {
5471 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5472 return result;
5473 }
5474
5475 /* RRSPACING(inf) = NaN */
5476 if (mpfr_inf_p (x->value.real))
5477 {
5478 mpfr_set_nan (result->value.real);
5479 return result;
5480 }
5481
5482 /* RRSPACING(NaN) = same NaN */
5483 if (mpfr_nan_p (x->value.real))
5484 {
5485 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
5486 return result;
5487 }
5488
5489 /* | x * 2**(-e) | * 2**p. */
5490 mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
5491 e = - (long int) mpfr_get_exp (x->value.real);
5492 mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
5493
5494 p = (long int) gfc_real_kinds[i].digits;
5495 mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
5496
5497 return range_check (result, "RRSPACING");
5498 }
5499
5500
5501 gfc_expr *
5502 gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
5503 {
5504 int k, neg_flag, power, exp_range;
5505 mpfr_t scale, radix;
5506 gfc_expr *result;
5507
5508 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5509 return NULL;
5510
5511 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5512
5513 if (mpfr_zero_p (x->value.real))
5514 {
5515 mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
5516 return result;
5517 }
5518
5519 k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
5520
5521 exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
5522
5523 /* This check filters out values of i that would overflow an int. */
5524 if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
5525 || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
5526 {
5527 gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
5528 gfc_free_expr (result);
5529 return &gfc_bad_expr;
5530 }
5531
5532 /* Compute scale = radix ** power. */
5533 power = mpz_get_si (i->value.integer);
5534
5535 if (power >= 0)
5536 neg_flag = 0;
5537 else
5538 {
5539 neg_flag = 1;
5540 power = -power;
5541 }
5542
5543 gfc_set_model_kind (x->ts.kind);
5544 mpfr_init (scale);
5545 mpfr_init (radix);
5546 mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
5547 mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
5548
5549 if (neg_flag)
5550 mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
5551 else
5552 mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
5553
5554 mpfr_clears (scale, radix, NULL);
5555
5556 return range_check (result, "SCALE");
5557 }
5558
5559
5560 /* Variants of strspn and strcspn that operate on wide characters. */
5561
5562 static size_t
5563 wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
5564 {
5565 size_t i = 0;
5566 const gfc_char_t *c;
5567
5568 while (s1[i])
5569 {
5570 for (c = s2; *c; c++)
5571 {
5572 if (s1[i] == *c)
5573 break;
5574 }
5575 if (*c == '\0')
5576 break;
5577 i++;
5578 }
5579
5580 return i;
5581 }
5582
5583 static size_t
5584 wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
5585 {
5586 size_t i = 0;
5587 const gfc_char_t *c;
5588
5589 while (s1[i])
5590 {
5591 for (c = s2; *c; c++)
5592 {
5593 if (s1[i] == *c)
5594 break;
5595 }
5596 if (*c)
5597 break;
5598 i++;
5599 }
5600
5601 return i;
5602 }
5603
5604
5605 gfc_expr *
5606 gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
5607 {
5608 gfc_expr *result;
5609 int back;
5610 size_t i;
5611 size_t indx, len, lenc;
5612 int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
5613
5614 if (k == -1)
5615 return &gfc_bad_expr;
5616
5617 if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
5618 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
5619 return NULL;
5620
5621 if (b != NULL && b->value.logical != 0)
5622 back = 1;
5623 else
5624 back = 0;
5625
5626 len = e->value.character.length;
5627 lenc = c->value.character.length;
5628
5629 if (len == 0 || lenc == 0)
5630 {
5631 indx = 0;
5632 }
5633 else
5634 {
5635 if (back == 0)
5636 {
5637 indx = wide_strcspn (e->value.character.string,
5638 c->value.character.string) + 1;
5639 if (indx > len)
5640 indx = 0;
5641 }
5642 else
5643 {
5644 i = 0;
5645 for (indx = len; indx > 0; indx--)
5646 {
5647 for (i = 0; i < lenc; i++)
5648 {
5649 if (c->value.character.string[i]
5650 == e->value.character.string[indx - 1])
5651 break;
5652 }
5653 if (i < lenc)
5654 break;
5655 }
5656 }
5657 }
5658
5659 result = gfc_get_int_expr (k, &e->where, indx);
5660 return range_check (result, "SCAN");
5661 }
5662
5663
5664 gfc_expr *
5665 gfc_simplify_selected_char_kind (gfc_expr *e)
5666 {
5667 int kind;
5668
5669 if (e->expr_type != EXPR_CONSTANT)
5670 return NULL;
5671
5672 if (gfc_compare_with_Cstring (e, "ascii", false) == 0
5673 || gfc_compare_with_Cstring (e, "default", false) == 0)
5674 kind = 1;
5675 else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
5676 kind = 4;
5677 else
5678 kind = -1;
5679
5680 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5681 }
5682
5683
5684 gfc_expr *
5685 gfc_simplify_selected_int_kind (gfc_expr *e)
5686 {
5687 int i, kind, range;
5688
5689 if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
5690 return NULL;
5691
5692 kind = INT_MAX;
5693
5694 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
5695 if (gfc_integer_kinds[i].range >= range
5696 && gfc_integer_kinds[i].kind < kind)
5697 kind = gfc_integer_kinds[i].kind;
5698
5699 if (kind == INT_MAX)
5700 kind = -1;
5701
5702 return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
5703 }
5704
5705
5706 gfc_expr *
5707 gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
5708 {
5709 int range, precision, radix, i, kind, found_precision, found_range,
5710 found_radix;
5711 locus *loc = &gfc_current_locus;
5712
5713 if (p == NULL)
5714 precision = 0;
5715 else
5716 {
5717 if (p->expr_type != EXPR_CONSTANT
5718 || gfc_extract_int (p, &precision) != NULL)
5719 return NULL;
5720 loc = &p->where;
5721 }
5722
5723 if (q == NULL)
5724 range = 0;
5725 else
5726 {
5727 if (q->expr_type != EXPR_CONSTANT
5728 || gfc_extract_int (q, &range) != NULL)
5729 return NULL;
5730
5731 if (!loc)
5732 loc = &q->where;
5733 }
5734
5735 if (rdx == NULL)
5736 radix = 0;
5737 else
5738 {
5739 if (rdx->expr_type != EXPR_CONSTANT
5740 || gfc_extract_int (rdx, &radix) != NULL)
5741 return NULL;
5742
5743 if (!loc)
5744 loc = &rdx->where;
5745 }
5746
5747 kind = INT_MAX;
5748 found_precision = 0;
5749 found_range = 0;
5750 found_radix = 0;
5751
5752 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
5753 {
5754 if (gfc_real_kinds[i].precision >= precision)
5755 found_precision = 1;
5756
5757 if (gfc_real_kinds[i].range >= range)
5758 found_range = 1;
5759
5760 if (radix == 0 || gfc_real_kinds[i].radix == radix)
5761 found_radix = 1;
5762
5763 if (gfc_real_kinds[i].precision >= precision
5764 && gfc_real_kinds[i].range >= range
5765 && (radix == 0 || gfc_real_kinds[i].radix == radix)
5766 && gfc_real_kinds[i].kind < kind)
5767 kind = gfc_real_kinds[i].kind;
5768 }
5769
5770 if (kind == INT_MAX)
5771 {
5772 if (found_radix && found_range && !found_precision)
5773 kind = -1;
5774 else if (found_radix && found_precision && !found_range)
5775 kind = -2;
5776 else if (found_radix && !found_precision && !found_range)
5777 kind = -3;
5778 else if (found_radix)
5779 kind = -4;
5780 else
5781 kind = -5;
5782 }
5783
5784 return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
5785 }
5786
5787
5788 gfc_expr *
5789 gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
5790 {
5791 gfc_expr *result;
5792 mpfr_t exp, absv, log2, pow2, frac;
5793 unsigned long exp2;
5794
5795 if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
5796 return NULL;
5797
5798 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
5799
5800 /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
5801 SET_EXPONENT (NaN) = same NaN */
5802 if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real))
5803 {
5804 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
5805 return result;
5806 }
5807
5808 /* SET_EXPONENT (inf) = NaN */
5809 if (mpfr_inf_p (x->value.real))
5810 {
5811 mpfr_set_nan (result->value.real);
5812 return result;
5813 }
5814
5815 gfc_set_model_kind (x->ts.kind);
5816 mpfr_init (absv);
5817 mpfr_init (log2);
5818 mpfr_init (exp);
5819 mpfr_init (pow2);
5820 mpfr_init (frac);
5821
5822 mpfr_abs (absv, x->value.real, GFC_RND_MODE);
5823 mpfr_log2 (log2, absv, GFC_RND_MODE);
5824
5825 mpfr_trunc (log2, log2);
5826 mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
5827
5828 /* Old exponent value, and fraction. */
5829 mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
5830
5831 mpfr_div (frac, absv, pow2, GFC_RND_MODE);
5832
5833 /* New exponent. */
5834 exp2 = (unsigned long) mpz_get_d (i->value.integer);
5835 mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
5836
5837 mpfr_clears (absv, log2, pow2, frac, NULL);
5838
5839 return range_check (result, "SET_EXPONENT");
5840 }
5841
5842
5843 gfc_expr *
5844 gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
5845 {
5846 mpz_t shape[GFC_MAX_DIMENSIONS];
5847 gfc_expr *result, *e, *f;
5848 gfc_array_ref *ar;
5849 int n;
5850 bool t;
5851 int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
5852
5853 if (source->rank == -1)
5854 return NULL;
5855
5856 result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
5857
5858 if (source->rank == 0)
5859 return result;
5860
5861 if (source->expr_type == EXPR_VARIABLE)
5862 {
5863 ar = gfc_find_array_ref (source);
5864 t = gfc_array_ref_shape (ar, shape);
5865 }
5866 else if (source->shape)
5867 {
5868 t = true;
5869 for (n = 0; n < source->rank; n++)
5870 {
5871 mpz_init (shape[n]);
5872 mpz_set (shape[n], source->shape[n]);
5873 }
5874 }
5875 else
5876 t = false;
5877
5878 for (n = 0; n < source->rank; n++)
5879 {
5880 e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
5881
5882 if (t)
5883 mpz_set (e->value.integer, shape[n]);
5884 else
5885 {
5886 mpz_set_ui (e->value.integer, n + 1);
5887
5888 f = simplify_size (source, e, k);
5889 gfc_free_expr (e);
5890 if (f == NULL)
5891 {
5892 gfc_free_expr (result);
5893 return NULL;
5894 }
5895 else
5896 e = f;
5897 }
5898
5899 if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
5900 {
5901 gfc_free_expr (result);
5902 if (t)
5903 gfc_clear_shape (shape, source->rank);
5904 return &gfc_bad_expr;
5905 }
5906
5907 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
5908 }
5909
5910 if (t)
5911 gfc_clear_shape (shape, source->rank);
5912
5913 return result;
5914 }
5915
5916
5917 static gfc_expr *
5918 simplify_size (gfc_expr *array, gfc_expr *dim, int k)
5919 {
5920 mpz_t size;
5921 gfc_expr *return_value;
5922 int d;
5923
5924 /* For unary operations, the size of the result is given by the size
5925 of the operand. For binary ones, it's the size of the first operand
5926 unless it is scalar, then it is the size of the second. */
5927 if (array->expr_type == EXPR_OP && !array->value.op.uop)
5928 {
5929 gfc_expr* replacement;
5930 gfc_expr* simplified;
5931
5932 switch (array->value.op.op)
5933 {
5934 /* Unary operations. */
5935 case INTRINSIC_NOT:
5936 case INTRINSIC_UPLUS:
5937 case INTRINSIC_UMINUS:
5938 case INTRINSIC_PARENTHESES:
5939 replacement = array->value.op.op1;
5940 break;
5941
5942 /* Binary operations. If any one of the operands is scalar, take
5943 the other one's size. If both of them are arrays, it does not
5944 matter -- try to find one with known shape, if possible. */
5945 default:
5946 if (array->value.op.op1->rank == 0)
5947 replacement = array->value.op.op2;
5948 else if (array->value.op.op2->rank == 0)
5949 replacement = array->value.op.op1;
5950 else
5951 {
5952 simplified = simplify_size (array->value.op.op1, dim, k);
5953 if (simplified)
5954 return simplified;
5955
5956 replacement = array->value.op.op2;
5957 }
5958 break;
5959 }
5960
5961 /* Try to reduce it directly if possible. */
5962 simplified = simplify_size (replacement, dim, k);
5963
5964 /* Otherwise, we build a new SIZE call. This is hopefully at least
5965 simpler than the original one. */
5966 if (!simplified)
5967 {
5968 gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
5969 simplified = gfc_build_intrinsic_call (gfc_current_ns,
5970 GFC_ISYM_SIZE, "size",
5971 array->where, 3,
5972 gfc_copy_expr (replacement),
5973 gfc_copy_expr (dim),
5974 kind);
5975 }
5976 return simplified;
5977 }
5978
5979 if (dim == NULL)
5980 {
5981 if (!gfc_array_size (array, &size))
5982 return NULL;
5983 }
5984 else
5985 {
5986 if (dim->expr_type != EXPR_CONSTANT)
5987 return NULL;
5988
5989 d = mpz_get_ui (dim->value.integer) - 1;
5990 if (!gfc_array_dimen_size (array, d, &size))
5991 return NULL;
5992 }
5993
5994 return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
5995 mpz_set (return_value->value.integer, size);
5996 mpz_clear (size);
5997
5998 return return_value;
5999 }
6000
6001
6002 gfc_expr *
6003 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6004 {
6005 gfc_expr *result;
6006 int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
6007
6008 if (k == -1)
6009 return &gfc_bad_expr;
6010
6011 result = simplify_size (array, dim, k);
6012 if (result == NULL || result == &gfc_bad_expr)
6013 return result;
6014
6015 return range_check (result, "SIZE");
6016 }
6017
6018
6019 /* SIZEOF and C_SIZEOF return the size in bytes of an array element
6020 multiplied by the array size. */
6021
6022 gfc_expr *
6023 gfc_simplify_sizeof (gfc_expr *x)
6024 {
6025 gfc_expr *result = NULL;
6026 mpz_t array_size;
6027
6028 if (x->ts.type == BT_CLASS || x->ts.deferred)
6029 return NULL;
6030
6031 if (x->ts.type == BT_CHARACTER
6032 && (!x->ts.u.cl || !x->ts.u.cl->length
6033 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
6034 return NULL;
6035
6036 if (x->rank && x->expr_type != EXPR_ARRAY
6037 && !gfc_array_size (x, &array_size))
6038 return NULL;
6039
6040 result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
6041 &x->where);
6042 mpz_set_si (result->value.integer, gfc_target_expr_size (x));
6043
6044 return result;
6045 }
6046
6047
6048 /* STORAGE_SIZE returns the size in bits of a single array element. */
6049
6050 gfc_expr *
6051 gfc_simplify_storage_size (gfc_expr *x,
6052 gfc_expr *kind)
6053 {
6054 gfc_expr *result = NULL;
6055 int k;
6056
6057 if (x->ts.type == BT_CLASS || x->ts.deferred)
6058 return NULL;
6059
6060 if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
6061 && (!x->ts.u.cl || !x->ts.u.cl->length
6062 || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
6063 return NULL;
6064
6065 k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
6066 if (k == -1)
6067 return &gfc_bad_expr;
6068
6069 result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
6070
6071 mpz_set_si (result->value.integer, gfc_element_size (x));
6072 mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
6073
6074 return range_check (result, "STORAGE_SIZE");
6075 }
6076
6077
6078 gfc_expr *
6079 gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
6080 {
6081 gfc_expr *result;
6082
6083 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6084 return NULL;
6085
6086 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6087
6088 switch (x->ts.type)
6089 {
6090 case BT_INTEGER:
6091 mpz_abs (result->value.integer, x->value.integer);
6092 if (mpz_sgn (y->value.integer) < 0)
6093 mpz_neg (result->value.integer, result->value.integer);
6094 break;
6095
6096 case BT_REAL:
6097 if (flag_sign_zero)
6098 mpfr_copysign (result->value.real, x->value.real, y->value.real,
6099 GFC_RND_MODE);
6100 else
6101 mpfr_setsign (result->value.real, x->value.real,
6102 mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
6103 break;
6104
6105 default:
6106 gfc_internal_error ("Bad type in gfc_simplify_sign");
6107 }
6108
6109 return result;
6110 }
6111
6112
6113 gfc_expr *
6114 gfc_simplify_sin (gfc_expr *x)
6115 {
6116 gfc_expr *result;
6117
6118 if (x->expr_type != EXPR_CONSTANT)
6119 return NULL;
6120
6121 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6122
6123 switch (x->ts.type)
6124 {
6125 case BT_REAL:
6126 mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
6127 break;
6128
6129 case BT_COMPLEX:
6130 gfc_set_model (x->value.real);
6131 mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6132 break;
6133
6134 default:
6135 gfc_internal_error ("in gfc_simplify_sin(): Bad type");
6136 }
6137
6138 return range_check (result, "SIN");
6139 }
6140
6141
6142 gfc_expr *
6143 gfc_simplify_sinh (gfc_expr *x)
6144 {
6145 gfc_expr *result;
6146
6147 if (x->expr_type != EXPR_CONSTANT)
6148 return NULL;
6149
6150 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6151
6152 switch (x->ts.type)
6153 {
6154 case BT_REAL:
6155 mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
6156 break;
6157
6158 case BT_COMPLEX:
6159 mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6160 break;
6161
6162 default:
6163 gcc_unreachable ();
6164 }
6165
6166 return range_check (result, "SINH");
6167 }
6168
6169
6170 /* The argument is always a double precision real that is converted to
6171 single precision. TODO: Rounding! */
6172
6173 gfc_expr *
6174 gfc_simplify_sngl (gfc_expr *a)
6175 {
6176 gfc_expr *result;
6177
6178 if (a->expr_type != EXPR_CONSTANT)
6179 return NULL;
6180
6181 result = gfc_real2real (a, gfc_default_real_kind);
6182 return range_check (result, "SNGL");
6183 }
6184
6185
6186 gfc_expr *
6187 gfc_simplify_spacing (gfc_expr *x)
6188 {
6189 gfc_expr *result;
6190 int i;
6191 long int en, ep;
6192
6193 if (x->expr_type != EXPR_CONSTANT)
6194 return NULL;
6195
6196 i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6197 result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
6198
6199 /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
6200 if (mpfr_zero_p (x->value.real))
6201 {
6202 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
6203 return result;
6204 }
6205
6206 /* SPACING(inf) = NaN */
6207 if (mpfr_inf_p (x->value.real))
6208 {
6209 mpfr_set_nan (result->value.real);
6210 return result;
6211 }
6212
6213 /* SPACING(NaN) = same NaN */
6214 if (mpfr_nan_p (x->value.real))
6215 {
6216 mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
6217 return result;
6218 }
6219
6220 /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
6221 are the radix, exponent of x, and precision. This excludes the
6222 possibility of subnormal numbers. Fortran 2003 states the result is
6223 b**max(e - p, emin - 1). */
6224
6225 ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
6226 en = (long int) gfc_real_kinds[i].min_exponent - 1;
6227 en = en > ep ? en : ep;
6228
6229 mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
6230 mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
6231
6232 return range_check (result, "SPACING");
6233 }
6234
6235
6236 gfc_expr *
6237 gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
6238 {
6239 gfc_expr *result = NULL;
6240 int nelem, i, j, dim, ncopies;
6241 mpz_t size;
6242
6243 if ((!gfc_is_constant_expr (source)
6244 && !is_constant_array_expr (source))
6245 || !gfc_is_constant_expr (dim_expr)
6246 || !gfc_is_constant_expr (ncopies_expr))
6247 return NULL;
6248
6249 gcc_assert (dim_expr->ts.type == BT_INTEGER);
6250 gfc_extract_int (dim_expr, &dim);
6251 dim -= 1; /* zero-base DIM */
6252
6253 gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
6254 gfc_extract_int (ncopies_expr, &ncopies);
6255 ncopies = MAX (ncopies, 0);
6256
6257 /* Do not allow the array size to exceed the limit for an array
6258 constructor. */
6259 if (source->expr_type == EXPR_ARRAY)
6260 {
6261 if (!gfc_array_size (source, &size))
6262 gfc_internal_error ("Failure getting length of a constant array.");
6263 }
6264 else
6265 mpz_init_set_ui (size, 1);
6266
6267 nelem = mpz_get_si (size) * ncopies;
6268 if (nelem > flag_max_array_constructor)
6269 {
6270 if (gfc_current_ns->sym_root->n.sym->attr.flavor == FL_PARAMETER)
6271 {
6272 gfc_error ("The number of elements (%d) in the array constructor "
6273 "at %L requires an increase of the allowed %d upper "
6274 "limit. See %<-fmax-array-constructor%> option.",
6275 nelem, &source->where, flag_max_array_constructor);
6276 return &gfc_bad_expr;
6277 }
6278 else
6279 return NULL;
6280 }
6281
6282 if (source->expr_type == EXPR_CONSTANT)
6283 {
6284 gcc_assert (dim == 0);
6285
6286 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
6287 &source->where);
6288 if (source->ts.type == BT_DERIVED)
6289 result->ts.u.derived = source->ts.u.derived;
6290 result->rank = 1;
6291 result->shape = gfc_get_shape (result->rank);
6292 mpz_init_set_si (result->shape[0], ncopies);
6293
6294 for (i = 0; i < ncopies; ++i)
6295 gfc_constructor_append_expr (&result->value.constructor,
6296 gfc_copy_expr (source), NULL);
6297 }
6298 else if (source->expr_type == EXPR_ARRAY)
6299 {
6300 int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
6301 gfc_constructor *source_ctor;
6302
6303 gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
6304 gcc_assert (dim >= 0 && dim <= source->rank);
6305
6306 result = gfc_get_array_expr (source->ts.type, source->ts.kind,
6307 &source->where);
6308 if (source->ts.type == BT_DERIVED)
6309 result->ts.u.derived = source->ts.u.derived;
6310 result->rank = source->rank + 1;
6311 result->shape = gfc_get_shape (result->rank);
6312
6313 for (i = 0, j = 0; i < result->rank; ++i)
6314 {
6315 if (i != dim)
6316 mpz_init_set (result->shape[i], source->shape[j++]);
6317 else
6318 mpz_init_set_si (result->shape[i], ncopies);
6319
6320 extent[i] = mpz_get_si (result->shape[i]);
6321 rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
6322 }
6323
6324 offset = 0;
6325 for (source_ctor = gfc_constructor_first (source->value.constructor);
6326 source_ctor; source_ctor = gfc_constructor_next (source_ctor))
6327 {
6328 for (i = 0; i < ncopies; ++i)
6329 gfc_constructor_insert_expr (&result->value.constructor,
6330 gfc_copy_expr (source_ctor->expr),
6331 NULL, offset + i * rstride[dim]);
6332
6333 offset += (dim == 0 ? ncopies : 1);
6334 }
6335 }
6336 else
6337 {
6338 gfc_error ("Simplification of SPREAD at %C not yet implemented");
6339 return &gfc_bad_expr;
6340 }
6341
6342 if (source->ts.type == BT_CHARACTER)
6343 result->ts.u.cl = source->ts.u.cl;
6344
6345 return result;
6346 }
6347
6348
6349 gfc_expr *
6350 gfc_simplify_sqrt (gfc_expr *e)
6351 {
6352 gfc_expr *result = NULL;
6353
6354 if (e->expr_type != EXPR_CONSTANT)
6355 return NULL;
6356
6357 switch (e->ts.type)
6358 {
6359 case BT_REAL:
6360 if (mpfr_cmp_si (e->value.real, 0) < 0)
6361 {
6362 gfc_error ("Argument of SQRT at %L has a negative value",
6363 &e->where);
6364 return &gfc_bad_expr;
6365 }
6366 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6367 mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
6368 break;
6369
6370 case BT_COMPLEX:
6371 gfc_set_model (e->value.real);
6372
6373 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
6374 mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
6375 break;
6376
6377 default:
6378 gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
6379 }
6380
6381 return range_check (result, "SQRT");
6382 }
6383
6384
6385 gfc_expr *
6386 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
6387 {
6388 return simplify_transformation (array, dim, mask, 0, gfc_add);
6389 }
6390
6391
6392 gfc_expr *
6393 gfc_simplify_cotan (gfc_expr *x)
6394 {
6395 gfc_expr *result;
6396 mpc_t swp, *val;
6397
6398 if (x->expr_type != EXPR_CONSTANT)
6399 return NULL;
6400
6401 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6402
6403 switch (x->ts.type)
6404 {
6405 case BT_REAL:
6406 mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE);
6407 break;
6408
6409 case BT_COMPLEX:
6410 /* There is no builtin mpc_cot, so compute cot = cos / sin. */
6411 val = &result->value.complex;
6412 mpc_init2 (swp, mpfr_get_default_prec ());
6413 mpc_cos (swp, x->value.complex, GFC_MPC_RND_MODE);
6414 mpc_sin (*val, x->value.complex, GFC_MPC_RND_MODE);
6415 mpc_div (*val, swp, *val, GFC_MPC_RND_MODE);
6416 mpc_clear (swp);
6417 break;
6418
6419 default:
6420 gcc_unreachable ();
6421 }
6422
6423 return range_check (result, "COTAN");
6424 }
6425
6426
6427 gfc_expr *
6428 gfc_simplify_tan (gfc_expr *x)
6429 {
6430 gfc_expr *result;
6431
6432 if (x->expr_type != EXPR_CONSTANT)
6433 return NULL;
6434
6435 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6436
6437 switch (x->ts.type)
6438 {
6439 case BT_REAL:
6440 mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
6441 break;
6442
6443 case BT_COMPLEX:
6444 mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6445 break;
6446
6447 default:
6448 gcc_unreachable ();
6449 }
6450
6451 return range_check (result, "TAN");
6452 }
6453
6454
6455 gfc_expr *
6456 gfc_simplify_tanh (gfc_expr *x)
6457 {
6458 gfc_expr *result;
6459
6460 if (x->expr_type != EXPR_CONSTANT)
6461 return NULL;
6462
6463 result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
6464
6465 switch (x->ts.type)
6466 {
6467 case BT_REAL:
6468 mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
6469 break;
6470
6471 case BT_COMPLEX:
6472 mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
6473 break;
6474
6475 default:
6476 gcc_unreachable ();
6477 }
6478
6479 return range_check (result, "TANH");
6480 }
6481
6482
6483 gfc_expr *
6484 gfc_simplify_tiny (gfc_expr *e)
6485 {
6486 gfc_expr *result;
6487 int i;
6488
6489 i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
6490
6491 result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
6492 mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
6493
6494 return result;
6495 }
6496
6497
6498 gfc_expr *
6499 gfc_simplify_trailz (gfc_expr *e)
6500 {
6501 unsigned long tz, bs;
6502 int i;
6503
6504 if (e->expr_type != EXPR_CONSTANT)
6505 return NULL;
6506
6507 i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
6508 bs = gfc_integer_kinds[i].bit_size;
6509 tz = mpz_scan1 (e->value.integer, 0);
6510
6511 return gfc_get_int_expr (gfc_default_integer_kind,
6512 &e->where, MIN (tz, bs));
6513 }
6514
6515
6516 gfc_expr *
6517 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
6518 {
6519 gfc_expr *result;
6520 gfc_expr *mold_element;
6521 size_t source_size;
6522 size_t result_size;
6523 size_t buffer_size;
6524 mpz_t tmp;
6525 unsigned char *buffer;
6526 size_t result_length;
6527
6528
6529 if (!gfc_is_constant_expr (source)
6530 || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
6531 || !gfc_is_constant_expr (size))
6532 return NULL;
6533
6534 if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
6535 &result_size, &result_length))
6536 return NULL;
6537
6538 /* Calculate the size of the source. */
6539 if (source->expr_type == EXPR_ARRAY
6540 && !gfc_array_size (source, &tmp))
6541 gfc_internal_error ("Failure getting length of a constant array.");
6542
6543 /* Create an empty new expression with the appropriate characteristics. */
6544 result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
6545 &source->where);
6546 result->ts = mold->ts;
6547
6548 mold_element = mold->expr_type == EXPR_ARRAY
6549 ? gfc_constructor_first (mold->value.constructor)->expr
6550 : mold;
6551
6552 /* Set result character length, if needed. Note that this needs to be
6553 set even for array expressions, in order to pass this information into
6554 gfc_target_interpret_expr. */
6555 if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
6556 result->value.character.length = mold_element->value.character.length;
6557
6558 /* Set the number of elements in the result, and determine its size. */
6559
6560 if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
6561 {
6562 result->expr_type = EXPR_ARRAY;
6563 result->rank = 1;
6564 result->shape = gfc_get_shape (1);
6565 mpz_init_set_ui (result->shape[0], result_length);
6566 }
6567 else
6568 result->rank = 0;
6569
6570 /* Allocate the buffer to store the binary version of the source. */
6571 buffer_size = MAX (source_size, result_size);
6572 buffer = (unsigned char*)alloca (buffer_size);
6573 memset (buffer, 0, buffer_size);
6574
6575 /* Now write source to the buffer. */
6576 gfc_target_encode_expr (source, buffer, buffer_size);
6577
6578 /* And read the buffer back into the new expression. */
6579 gfc_target_interpret_expr (buffer, buffer_size, result, false);
6580
6581 return result;
6582 }
6583
6584
6585 gfc_expr *
6586 gfc_simplify_transpose (gfc_expr *matrix)
6587 {
6588 int row, matrix_rows, col, matrix_cols;
6589 gfc_expr *result;
6590
6591 if (!is_constant_array_expr (matrix))
6592 return NULL;
6593
6594 gcc_assert (matrix->rank == 2);
6595
6596 result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
6597 &matrix->where);
6598 result->rank = 2;
6599 result->shape = gfc_get_shape (result->rank);
6600 mpz_set (result->shape[0], matrix->shape[1]);
6601 mpz_set (result->shape[1], matrix->shape[0]);
6602
6603 if (matrix->ts.type == BT_CHARACTER)
6604 result->ts.u.cl = matrix->ts.u.cl;
6605 else if (matrix->ts.type == BT_DERIVED)
6606 result->ts.u.derived = matrix->ts.u.derived;
6607
6608 matrix_rows = mpz_get_si (matrix->shape[0]);
6609 matrix_cols = mpz_get_si (matrix->shape[1]);
6610 for (row = 0; row < matrix_rows; ++row)
6611 for (col = 0; col < matrix_cols; ++col)
6612 {
6613 gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
6614 col * matrix_rows + row);
6615 gfc_constructor_insert_expr (&result->value.constructor,
6616 gfc_copy_expr (e), &matrix->where,
6617 row * matrix_cols + col);
6618 }
6619
6620 return result;
6621 }
6622
6623
6624 gfc_expr *
6625 gfc_simplify_trim (gfc_expr *e)
6626 {
6627 gfc_expr *result;
6628 int count, i, len, lentrim;
6629
6630 if (e->expr_type != EXPR_CONSTANT)
6631 return NULL;
6632
6633 len = e->value.character.length;
6634 for (count = 0, i = 1; i <= len; ++i)
6635 {
6636 if (e->value.character.string[len - i] == ' ')
6637 count++;
6638 else
6639 break;
6640 }
6641
6642 lentrim = len - count;
6643
6644 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
6645 for (i = 0; i < lentrim; i++)
6646 result->value.character.string[i] = e->value.character.string[i];
6647
6648 return result;
6649 }
6650
6651
6652 gfc_expr *
6653 gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
6654 {
6655 gfc_expr *result;
6656 gfc_ref *ref;
6657 gfc_array_spec *as;
6658 gfc_constructor *sub_cons;
6659 bool first_image;
6660 int d;
6661
6662 if (!is_constant_array_expr (sub))
6663 return NULL;
6664
6665 /* Follow any component references. */
6666 as = coarray->symtree->n.sym->as;
6667 for (ref = coarray->ref; ref; ref = ref->next)
6668 if (ref->type == REF_COMPONENT)
6669 as = ref->u.ar.as;
6670
6671 if (as->type == AS_DEFERRED)
6672 return NULL;
6673
6674 /* "valid sequence of cosubscripts" are required; thus, return 0 unless
6675 the cosubscript addresses the first image. */
6676
6677 sub_cons = gfc_constructor_first (sub->value.constructor);
6678 first_image = true;
6679
6680 for (d = 1; d <= as->corank; d++)
6681 {
6682 gfc_expr *ca_bound;
6683 int cmp;
6684
6685 gcc_assert (sub_cons != NULL);
6686
6687 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
6688 NULL, true);
6689 if (ca_bound == NULL)
6690 return NULL;
6691
6692 if (ca_bound == &gfc_bad_expr)
6693 return ca_bound;
6694
6695 cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
6696
6697 if (cmp == 0)
6698 {
6699 gfc_free_expr (ca_bound);
6700 sub_cons = gfc_constructor_next (sub_cons);
6701 continue;
6702 }
6703
6704 first_image = false;
6705
6706 if (cmp > 0)
6707 {
6708 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6709 "SUB has %ld and COARRAY lower bound is %ld)",
6710 &coarray->where, d,
6711 mpz_get_si (sub_cons->expr->value.integer),
6712 mpz_get_si (ca_bound->value.integer));
6713 gfc_free_expr (ca_bound);
6714 return &gfc_bad_expr;
6715 }
6716
6717 gfc_free_expr (ca_bound);
6718
6719 /* Check whether upperbound is valid for the multi-images case. */
6720 if (d < as->corank)
6721 {
6722 ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
6723 NULL, true);
6724 if (ca_bound == &gfc_bad_expr)
6725 return ca_bound;
6726
6727 if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
6728 && mpz_cmp (ca_bound->value.integer,
6729 sub_cons->expr->value.integer) < 0)
6730 {
6731 gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
6732 "SUB has %ld and COARRAY upper bound is %ld)",
6733 &coarray->where, d,
6734 mpz_get_si (sub_cons->expr->value.integer),
6735 mpz_get_si (ca_bound->value.integer));
6736 gfc_free_expr (ca_bound);
6737 return &gfc_bad_expr;
6738 }
6739
6740 if (ca_bound)
6741 gfc_free_expr (ca_bound);
6742 }
6743
6744 sub_cons = gfc_constructor_next (sub_cons);
6745 }
6746
6747 gcc_assert (sub_cons == NULL);
6748
6749 if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image)
6750 return NULL;
6751
6752 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6753 &gfc_current_locus);
6754 if (first_image)
6755 mpz_set_si (result->value.integer, 1);
6756 else
6757 mpz_set_si (result->value.integer, 0);
6758
6759 return result;
6760 }
6761
6762
6763 gfc_expr *
6764 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
6765 gfc_expr *distance ATTRIBUTE_UNUSED)
6766 {
6767 if (flag_coarray != GFC_FCOARRAY_SINGLE)
6768 return NULL;
6769
6770 /* If no coarray argument has been passed or when the first argument
6771 is actually a distance argment. */
6772 if (coarray == NULL || !gfc_is_coarray (coarray))
6773 {
6774 gfc_expr *result;
6775 /* FIXME: gfc_current_locus is wrong. */
6776 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
6777 &gfc_current_locus);
6778 mpz_set_si (result->value.integer, 1);
6779 return result;
6780 }
6781
6782 /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
6783 return simplify_cobound (coarray, dim, NULL, 0);
6784 }
6785
6786
6787 gfc_expr *
6788 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6789 {
6790 return simplify_bound (array, dim, kind, 1);
6791 }
6792
6793 gfc_expr *
6794 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
6795 {
6796 return simplify_cobound (array, dim, kind, 1);
6797 }
6798
6799
6800 gfc_expr *
6801 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
6802 {
6803 gfc_expr *result, *e;
6804 gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
6805
6806 if (!is_constant_array_expr (vector)
6807 || !is_constant_array_expr (mask)
6808 || (!gfc_is_constant_expr (field)
6809 && !is_constant_array_expr (field)))
6810 return NULL;
6811
6812 result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
6813 &vector->where);
6814 if (vector->ts.type == BT_DERIVED)
6815 result->ts.u.derived = vector->ts.u.derived;
6816 result->rank = mask->rank;
6817 result->shape = gfc_copy_shape (mask->shape, mask->rank);
6818
6819 if (vector->ts.type == BT_CHARACTER)
6820 result->ts.u.cl = vector->ts.u.cl;
6821
6822 vector_ctor = gfc_constructor_first (vector->value.constructor);
6823 mask_ctor = gfc_constructor_first (mask->value.constructor);
6824 field_ctor
6825 = field->expr_type == EXPR_ARRAY
6826 ? gfc_constructor_first (field->value.constructor)
6827 : NULL;
6828
6829 while (mask_ctor)
6830 {
6831 if (mask_ctor->expr->value.logical)
6832 {
6833 gcc_assert (vector_ctor);
6834 e = gfc_copy_expr (vector_ctor->expr);
6835 vector_ctor = gfc_constructor_next (vector_ctor);
6836 }
6837 else if (field->expr_type == EXPR_ARRAY)
6838 e = gfc_copy_expr (field_ctor->expr);
6839 else
6840 e = gfc_copy_expr (field);
6841
6842 gfc_constructor_append_expr (&result->value.constructor, e, NULL);
6843
6844 mask_ctor = gfc_constructor_next (mask_ctor);
6845 field_ctor = gfc_constructor_next (field_ctor);
6846 }
6847
6848 return result;
6849 }
6850
6851
6852 gfc_expr *
6853 gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
6854 {
6855 gfc_expr *result;
6856 int back;
6857 size_t index, len, lenset;
6858 size_t i;
6859 int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
6860
6861 if (k == -1)
6862 return &gfc_bad_expr;
6863
6864 if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
6865 || ( b != NULL && b->expr_type != EXPR_CONSTANT))
6866 return NULL;
6867
6868 if (b != NULL && b->value.logical != 0)
6869 back = 1;
6870 else
6871 back = 0;
6872
6873 result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
6874
6875 len = s->value.character.length;
6876 lenset = set->value.character.length;
6877
6878 if (len == 0)
6879 {
6880 mpz_set_ui (result->value.integer, 0);
6881 return result;
6882 }
6883
6884 if (back == 0)
6885 {
6886 if (lenset == 0)
6887 {
6888 mpz_set_ui (result->value.integer, 1);
6889 return result;
6890 }
6891
6892 index = wide_strspn (s->value.character.string,
6893 set->value.character.string) + 1;
6894 if (index > len)
6895 index = 0;
6896
6897 }
6898 else
6899 {
6900 if (lenset == 0)
6901 {
6902 mpz_set_ui (result->value.integer, len);
6903 return result;
6904 }
6905 for (index = len; index > 0; index --)
6906 {
6907 for (i = 0; i < lenset; i++)
6908 {
6909 if (s->value.character.string[index - 1]
6910 == set->value.character.string[i])
6911 break;
6912 }
6913 if (i == lenset)
6914 break;
6915 }
6916 }
6917
6918 mpz_set_ui (result->value.integer, index);
6919 return result;
6920 }
6921
6922
6923 gfc_expr *
6924 gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
6925 {
6926 gfc_expr *result;
6927 int kind;
6928
6929 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
6930 return NULL;
6931
6932 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
6933
6934 switch (x->ts.type)
6935 {
6936 case BT_INTEGER:
6937 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
6938 mpz_xor (result->value.integer, x->value.integer, y->value.integer);
6939 return range_check (result, "XOR");
6940
6941 case BT_LOGICAL:
6942 return gfc_get_logical_expr (kind, &x->where,
6943 (x->value.logical && !y->value.logical)
6944 || (!x->value.logical && y->value.logical));
6945
6946 default:
6947 gcc_unreachable ();
6948 }
6949 }
6950
6951
6952 /****************** Constant simplification *****************/
6953
6954 /* Master function to convert one constant to another. While this is
6955 used as a simplification function, it requires the destination type
6956 and kind information which is supplied by a special case in
6957 do_simplify(). */
6958
6959 gfc_expr *
6960 gfc_convert_constant (gfc_expr *e, bt type, int kind)
6961 {
6962 gfc_expr *g, *result, *(*f) (gfc_expr *, int);
6963 gfc_constructor *c;
6964
6965 switch (e->ts.type)
6966 {
6967 case BT_INTEGER:
6968 switch (type)
6969 {
6970 case BT_INTEGER:
6971 f = gfc_int2int;
6972 break;
6973 case BT_REAL:
6974 f = gfc_int2real;
6975 break;
6976 case BT_COMPLEX:
6977 f = gfc_int2complex;
6978 break;
6979 case BT_LOGICAL:
6980 f = gfc_int2log;
6981 break;
6982 default:
6983 goto oops;
6984 }
6985 break;
6986
6987 case BT_REAL:
6988 switch (type)
6989 {
6990 case BT_INTEGER:
6991 f = gfc_real2int;
6992 break;
6993 case BT_REAL:
6994 f = gfc_real2real;
6995 break;
6996 case BT_COMPLEX:
6997 f = gfc_real2complex;
6998 break;
6999 default:
7000 goto oops;
7001 }
7002 break;
7003
7004 case BT_COMPLEX:
7005 switch (type)
7006 {
7007 case BT_INTEGER:
7008 f = gfc_complex2int;
7009 break;
7010 case BT_REAL:
7011 f = gfc_complex2real;
7012 break;
7013 case BT_COMPLEX:
7014 f = gfc_complex2complex;
7015 break;
7016
7017 default:
7018 goto oops;
7019 }
7020 break;
7021
7022 case BT_LOGICAL:
7023 switch (type)
7024 {
7025 case BT_INTEGER:
7026 f = gfc_log2int;
7027 break;
7028 case BT_LOGICAL:
7029 f = gfc_log2log;
7030 break;
7031 default:
7032 goto oops;
7033 }
7034 break;
7035
7036 case BT_HOLLERITH:
7037 switch (type)
7038 {
7039 case BT_INTEGER:
7040 f = gfc_hollerith2int;
7041 break;
7042
7043 case BT_REAL:
7044 f = gfc_hollerith2real;
7045 break;
7046
7047 case BT_COMPLEX:
7048 f = gfc_hollerith2complex;
7049 break;
7050
7051 case BT_CHARACTER:
7052 f = gfc_hollerith2character;
7053 break;
7054
7055 case BT_LOGICAL:
7056 f = gfc_hollerith2logical;
7057 break;
7058
7059 default:
7060 goto oops;
7061 }
7062 break;
7063
7064 default:
7065 oops:
7066 gfc_internal_error ("gfc_convert_constant(): Unexpected type");
7067 }
7068
7069 result = NULL;
7070
7071 switch (e->expr_type)
7072 {
7073 case EXPR_CONSTANT:
7074 result = f (e, kind);
7075 if (result == NULL)
7076 return &gfc_bad_expr;
7077 break;
7078
7079 case EXPR_ARRAY:
7080 if (!gfc_is_constant_expr (e))
7081 break;
7082
7083 result = gfc_get_array_expr (type, kind, &e->where);
7084 result->shape = gfc_copy_shape (e->shape, e->rank);
7085 result->rank = e->rank;
7086
7087 for (c = gfc_constructor_first (e->value.constructor);
7088 c; c = gfc_constructor_next (c))
7089 {
7090 gfc_expr *tmp;
7091 if (c->iterator == NULL)
7092 tmp = f (c->expr, kind);
7093 else
7094 {
7095 g = gfc_convert_constant (c->expr, type, kind);
7096 if (g == &gfc_bad_expr)
7097 {
7098 gfc_free_expr (result);
7099 return g;
7100 }
7101 tmp = g;
7102 }
7103
7104 if (tmp == NULL)
7105 {
7106 gfc_free_expr (result);
7107 return NULL;
7108 }
7109
7110 gfc_constructor_append_expr (&result->value.constructor,
7111 tmp, &c->where);
7112 }
7113
7114 break;
7115
7116 default:
7117 break;
7118 }
7119
7120 return result;
7121 }
7122
7123
7124 /* Function for converting character constants. */
7125 gfc_expr *
7126 gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
7127 {
7128 gfc_expr *result;
7129 int i;
7130
7131 if (!gfc_is_constant_expr (e))
7132 return NULL;
7133
7134 if (e->expr_type == EXPR_CONSTANT)
7135 {
7136 /* Simple case of a scalar. */
7137 result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
7138 if (result == NULL)
7139 return &gfc_bad_expr;
7140
7141 result->value.character.length = e->value.character.length;
7142 result->value.character.string
7143 = gfc_get_wide_string (e->value.character.length + 1);
7144 memcpy (result->value.character.string, e->value.character.string,
7145 (e->value.character.length + 1) * sizeof (gfc_char_t));
7146
7147 /* Check we only have values representable in the destination kind. */
7148 for (i = 0; i < result->value.character.length; i++)
7149 if (!gfc_check_character_range (result->value.character.string[i],
7150 kind))
7151 {
7152 gfc_error ("Character %qs in string at %L cannot be converted "
7153 "into character kind %d",
7154 gfc_print_wide_char (result->value.character.string[i]),
7155 &e->where, kind);
7156 return &gfc_bad_expr;
7157 }
7158
7159 return result;
7160 }
7161 else if (e->expr_type == EXPR_ARRAY)
7162 {
7163 /* For an array constructor, we convert each constructor element. */
7164 gfc_constructor *c;
7165
7166 result = gfc_get_array_expr (type, kind, &e->where);
7167 result->shape = gfc_copy_shape (e->shape, e->rank);
7168 result->rank = e->rank;
7169 result->ts.u.cl = e->ts.u.cl;
7170
7171 for (c = gfc_constructor_first (e->value.constructor);
7172 c; c = gfc_constructor_next (c))
7173 {
7174 gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
7175 if (tmp == &gfc_bad_expr)
7176 {
7177 gfc_free_expr (result);
7178 return &gfc_bad_expr;
7179 }
7180
7181 if (tmp == NULL)
7182 {
7183 gfc_free_expr (result);
7184 return NULL;
7185 }
7186
7187 gfc_constructor_append_expr (&result->value.constructor,
7188 tmp, &c->where);
7189 }
7190
7191 return result;
7192 }
7193 else
7194 return NULL;
7195 }
7196
7197
7198 gfc_expr *
7199 gfc_simplify_compiler_options (void)
7200 {
7201 char *str;
7202 gfc_expr *result;
7203
7204 str = gfc_get_option_string ();
7205 result = gfc_get_character_expr (gfc_default_character_kind,
7206 &gfc_current_locus, str, strlen (str));
7207 free (str);
7208 return result;
7209 }
7210
7211
7212 gfc_expr *
7213 gfc_simplify_compiler_version (void)
7214 {
7215 char *buffer;
7216 size_t len;
7217
7218 len = strlen ("GCC version ") + strlen (version_string);
7219 buffer = XALLOCAVEC (char, len + 1);
7220 snprintf (buffer, len + 1, "GCC version %s", version_string);
7221 return gfc_get_character_expr (gfc_default_character_kind,
7222 &gfc_current_locus, buffer, len);
7223 }
7224
7225 /* Simplification routines for intrinsics of IEEE modules. */
7226
7227 gfc_expr *
7228 simplify_ieee_selected_real_kind (gfc_expr *expr)
7229 {
7230 gfc_actual_arglist *arg;
7231 gfc_expr *p = NULL, *q = NULL, *rdx = NULL;
7232
7233 arg = expr->value.function.actual;
7234 p = arg->expr;
7235 if (arg->next)
7236 {
7237 q = arg->next->expr;
7238 if (arg->next->next)
7239 rdx = arg->next->next->expr;
7240 }
7241
7242 /* Currently, if IEEE is supported and this module is built, it means
7243 all our floating-point types conform to IEEE. Hence, we simply handle
7244 IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
7245 return gfc_simplify_selected_real_kind (p, q, rdx);
7246 }
7247
7248 gfc_expr *
7249 simplify_ieee_support (gfc_expr *expr)
7250 {
7251 /* We consider that if the IEEE modules are loaded, we have full support
7252 for flags, halting and rounding, which are the three functions
7253 (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
7254 expressions. One day, we will need libgfortran to detect support and
7255 communicate it back to us, allowing for partial support. */
7256
7257 return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where,
7258 true);
7259 }
7260
7261 bool
7262 matches_ieee_function_name (gfc_symbol *sym, const char *name)
7263 {
7264 int n = strlen(name);
7265
7266 if (!strncmp(sym->name, name, n))
7267 return true;
7268
7269 /* If a generic was used and renamed, we need more work to find out.
7270 Compare the specific name. */
7271 if (sym->generic && !strncmp(sym->generic->sym->name, name, n))
7272 return true;
7273
7274 return false;
7275 }
7276
7277 gfc_expr *
7278 gfc_simplify_ieee_functions (gfc_expr *expr)
7279 {
7280 gfc_symbol* sym = expr->symtree->n.sym;
7281
7282 if (matches_ieee_function_name(sym, "ieee_selected_real_kind"))
7283 return simplify_ieee_selected_real_kind (expr);
7284 else if (matches_ieee_function_name(sym, "ieee_support_flag")
7285 || matches_ieee_function_name(sym, "ieee_support_halting")
7286 || matches_ieee_function_name(sym, "ieee_support_rounding"))
7287 return simplify_ieee_support (expr);
7288 else
7289 return NULL;
7290 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org